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

Question

我有一个程序需要从EXCEL导入初始数据，里面有姓名，身份证号码，等个人信息，同时对应个人的一些业务数据，在一张EXCEL文件中，我需要将这个表分别导入两个ACCESS数据表中，一个存每个人唯一客户ID的《客户信息表》（EXCEL同一个身份证号会有多条业务数据），和含客户ID的客户业务数据表中。请高手指教。
比如：
EXCEL表：
姓名 证件号 金额
张三 123 100
张三 123 200
李四 121 100

生成ACCESS
客户ID 姓名 证件号
0001 张三 123
0002 李四 121

客户ID 金额
0001 100
0001 200
0002 100
是思路，不要一堆的代码》

Answer 1

以下代码是一个大神写的
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
一个导入按钮 一个导出按钮

Answer 2

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

Answer 3

学习。