求将EXCEL文件导入到ACCESS数据库，VB代码？

以下代码是一个大神写的
Option Explicit
Private AccessFile As String
Private ExcelFile As String
Private ExcelApp As Excel.Application
Private Sub Command2_Click()
Dim Conn As ADODB.Connection
Dim XlsSheet As Excel.Worksheet
Dim i As Long, j As Long, k As Long
Dim l As Integer
Dim Sql As String, InsertSql As String, ValStr As String
Dim MaxWidth As Long, FieldLine As Long
Dim Rs As ADODB.Recordset, RsData As ADODB.Recordset
'first: get two filenames

CommonDialog1.Filter = "Access File(*.mdb)|*.mdb"
CommonDialog1.DialogTitle = "Open Access File"
CommonDialog1.FileName = ""
CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then Exit Sub
AccessFile = CommonDialog1.FileName

CommonDialog1.Filter = "Excel File(*.xls)|*.xls"
CommonDialog1.DialogTitle = "Export to Excel File"
CommonDialog1.FileName = ""
CommonDialog1.ShowSave
If CommonDialog1.FileName = "" Then Exit Sub
ExcelFile = CommonDialog1.FileName

On Error GoTo ErrOpenXls
If Dir(ExcelFile) = "" Then
ExcelApp.Workbooks.Add
ExcelApp.ActiveWorkbook.SaveAs ExcelFile
Else
ExcelApp.Workbooks.Open ExcelFile
End If
On Error GoTo 0

On Error GoTo ErrOpenMdb
Set Conn = CreateObject("ADODB.Connection")
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & AccessFile
On Error GoTo 0

Set Rs = Conn.OpenSchema(adSchemaTables) 'get table name list
Set RsData = CreateObject("ADODB.Recordset")
While Not Rs.EOF
If Rs("TABLE_TYPE").Value = "TABLE" Then
If Left(Rs("TABLE_NAME").Value, 1) <> "~" Then
l = 0
For i = 1 To ExcelApp.ActiveWorkbook.Worksheets.Count
Set XlsSheet = ExcelApp.ActiveWorkbook.Sheets(i)
If Rs("TABLE_NAME").Value = XlsSheet.Name Then
l = MsgBox("Same table name exist, overwrite it?", vbQuestion + vbYesNo + vbDefaultButton2, "Overrite")
If l = vbYes Then
XlsSheet.Range("1:65536").Delete
End If
Exit For
End If
Next i
If l = 0 Then
Set XlsSheet = ExcelApp.ActiveWorkbook.Worksheets.Add
XlsSheet.Name = Rs("TABLE_NAME")
End If
If l = vbYes Or l = 0 Then
RsData.Open "Select * from " & Rs("TABLE_NAME").Value, Conn, adOpenKeyset, adLockOptimistic
For i = 1 To Rs.Fields.Count
XlsSheet.Cells(1, i) = RsData.Fields(i - 1).Name
Next i
i = 2
While Not RsData.EOF
For j = 1 To Rs.Fields.Count
XlsSheet.Cells(i, j) = RsData(j - 1).Value
Next j
i = i + 1
RsData.MoveNext
Wend
RsData.Close
End If
End If
End If
Rs.MoveNext
Wend

Rs.Close
Conn.Close
ExcelApp.ActiveWorkbook.Save
ExcelApp.ActiveWorkbook.Close
Set RsData = Nothing
Set Rs = Nothing
Set Conn = Nothing
Exit Sub
ErrOpenXls:
MsgBox "Open Excel File Failed", vbCritical, "Error"
Exit Sub

ErrOpenMdb:
MsgBox "Access File Connect Failed", vbCritical, "Error"
ExcelApp.ActiveWindow.Close
Exit Sub
End Sub

Private Sub Command1_Click()
Dim Conn As ADODB.Connection
Dim XlsSheet As Excel.Worksheet
Dim i As Long, j As Long, k As Long
Dim l As Integer
Dim Sql As String, InsertSql As String, ValStr As String
Dim MaxWidth As Long, FieldLine As Long
Dim Rs As ADODB.Recordset
'first: get two filenames

CommonDialog1.Filter = "Excel File(*.xls)|*.xls"
CommonDialog1.DialogTitle = "Open Excel File"
CommonDialog1.FileName = ""
CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then Exit Sub
ExcelFile = CommonDialog1.FileName

CommonDialog1.Filter = "Access File(*.mdb)|*.mdb"
CommonDialog1.DialogTitle = "Export to Access File"
CommonDialog1.FileName = ""
CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then Exit Sub
AccessFile = CommonDialog1.FileName

On Error GoTo ErrOpenXls
ExcelApp.Workbooks.Open ExcelFile
On Error GoTo 0

On Error GoTo ErrOpenMdb
Set Conn = CreateObject("ADODB.Connection")
Conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & AccessFile
On Error GoTo 0

Set Rs = Conn.OpenSchema(adSchemaTables) 'get table name list

For i = 1 To ExcelApp.ActiveWorkbook.Worksheets.Count
Set XlsSheet = ExcelApp.ActiveWorkbook.Sheets(i)

Rs.MoveFirst
l = vbYes
Do While Not Rs.EOF
If Rs("TABLE_TYPE").Value = "TABLE" Then 'check if exist
If Rs("TABLE_NAME").Value = XlsSheet.Name Then
l = MsgBox("Same table name exist, overwrite it?", vbQuestion + vbYesNo + vbDefaultButton2, "Overrite")
If l = vbYes Then
Conn.Execute "drop table " & XlsSheet.Name
End If
Exit Do
End If
End If
Rs.MoveNext
Loop

If l = vbYes Then
Sql = "create table " & XlsSheet.Name & " ("
MaxWidth = 0
For j = 1 To XlsSheet.Range("A65536").End(xlUp).Row
For k = 1 To XlsSheet.Range("IV" & j).End(xlToLeft).Column
If XlsSheet.Cells(j, k).MergeCells = True Or XlsSheet.Cells(j, k) = "" Then
Exit For 'contain a merged cell, skip this line
End If
Next k
If k > XlsSheet.Range("IV" & j).End(xlToLeft).Column Then
'get the max width of this sheet
MaxWidth = XlsSheet.Range("IV" & j).End(xlToLeft).Column
'there is no merged cell in this line, use it as field name line
Exit For
End If
Next j

If MaxWidth > 0 Then
FieldLine = j
InsertSql = ""
For j = 1 To MaxWidth
If IsNumeric(XlsSheet.Cells(FieldLine + 1, j)) Then
Sql = Sql & XlsSheet.Cells(FieldLine, j) & " int,"
Else
Sql = Sql & XlsSheet.Cells(FieldLine, j) & " varchar(255),"
End If
InsertSql = InsertSql & XlsSheet.Cells(FieldLine, j) & ","
Next j
Sql = Left(Sql, Len(Sql) - 1) 'remove last char
InsertSql = Left(InsertSql, Len(InsertSql) - 1)
Sql = Sql & ")"

Conn.Execute Sql 'create table

For j = FieldLine + 1 To XlsSheet.Range("A65536").End(xlUp).Row
ValStr = ""
For k = 1 To MaxWidth
If IsNumeric(XlsSheet.Cells(FieldLine + 1, k)) Then
ValStr = ValStr & Val(XlsSheet.Cells(j, k)) & ","
Else
ValStr = ValStr & "'" & XlsSheet.Cells(j, k) & "',"
End If
Next k
ValStr = Left(ValStr, Len(ValStr) - 1)
Conn.Execute "insert into " & XlsSheet.Name & " (" & InsertSql & ") values (" & ValStr & ")"
Next j
Else
MsgBox "Failed to get field name, skip this sheet", vbCritical, "Error"
End If
End If
Next i

Rs.Close
Conn.Close
ExcelApp.ActiveWorkbook.Close
Set Rs = Nothing
Set Conn = Nothing
Exit Sub
ErrOpenXls:
MsgBox "Open Excel File Failed", vbCritical, "Error"
Exit Sub

ErrOpenMdb:
MsgBox "Access File Connect Failed", vbCritical, "Error"
ExcelApp.ActiveWindow.Close
Exit Sub
End Sub

Private Sub Form_Load()
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = False
Command1.Caption = "Excel To Access"
Command2.Caption = "Access to Excel"
Label1.Caption = "Excel to Access note: Access file must be exist firstly."
End Sub

Private Sub Form_Unload(Cancel As Integer)
ExcelApp.Quit 'here quit it
End Sub
一个导入按钮 一个导出按钮

07版access 外部数据 --excel--直接导入

学习。