在access中批量导入excel文件

 Function TransExcelToAccess(folderspec As String, tratablename As String) '本函数读取folderspec目录下的XLS文件,并将每个文件的数据区域头两行的数据前面加个'号,以表示导入的时候以文本方式导入 On Error GoTo err1 Dim objRs As New ADODB.Recordset Dim objFields As ADODB.Fields Dim myArray() As String '存放access表中字段名 Dim tempArray() As String '存放新增的字段名 Dim fs, f, f1, fc, s, t, u, a, b, c, intloop Set fs = CreateObject("Scripting.FileSystemObject") If Not fs.FolderExists(folderspec) Then MsgBox "指定的文件夹不存在!" Exit Function End If Set f = fs.GetFolder(folderspec) Set fc = f.Files b = 0 '记录导入的文件数量 c = 0 'access表中应有的字段数量 u = 1 Dim xlApp As Excel.Application '也可以用Excel.Application,用object就不要引用Microsoft Excel 11.0 Object Library Debug.Print "目录下总共有" & fc.Count & "个文件!" For Each f1 In fc If LCase(Right(f1.Name, 3)) = "xls" Then 'Set xlApp = New Excel.Application Set xlApp = CreateObject("Excel.Application") xlApp.Workbooks.Open (folderspec & "/" & f1.Name) xlApp.Visible = False '隐藏Excel应用程序窗口 xlApp.Sheets(1).Activate xlApp.Sheets(1).Range("A1").Select a = xlApp.ActiveCell.CurrentRegion.Columns.Count '数据区域的列数 If xlApp.ActiveCell.CurrentRegion.Rows.Count > 1 Then '有数据时 For Each s In xlApp.Worksheets(1).Range(xlApp.Worksheets(1).Cells(1, 1), xlApp.Worksheets(1).Cells(2, a)) 'xlApp.ActiveCell.CurrentRegion.Cells s.Value = "'" & s.Value 's.Value = Right(s.Value, Len(s.Value) - 1) '在数据前去掉' Next If b >= 1 Then '第二次导入数据前,检查字段名 For Each t In xlApp.Worksheets(1).Range(xlApp.Worksheets(1).Cells(1, 1), xlApp.Worksheets(1).Cells(1, a)) Debug.Print f1.Name & t.Value If t.Value = "" Then tempArray = Filter(myArray, "NoName") If UBound(tempArray) = -1 Then c = c + 1 ReDim Preserve myArray(0 To c) myArray(c) = "NoName" CurrentDb.Execute "ALTER TABLE " & tratablename & " ADD COLUMN NoName CHAR(255);" Else Do While UBound(tempArray) <> -1 tempArray = Filter(myArray, "NoName" & u) If UBound(tempArray) = -1 Then c = c + 1 ReDim Preserve myArray(0 To c) myArray(c) = "NoName" & u CurrentDb.Execute "ALTER TABLE " & tratablename & " ADD COLUMN NoName" & u & " CHAR(255);" u = u + 1 Exit Do Else u = u + 1 End If Loop End If Else tempArray = Filter(myArray, t.Value) If UBound(tempArray) = -1 Then c = c + 1 ReDim Preserve myArray(0 To c) myArray(c) = t.Value CurrentDb.Execute "ALTER TABLE " & tratablename & " ADD COLUMN " & t.Value & " CHAR(255);" End If End If Next End If xlApp.Workbooks(1).Save xlApp.Quit Set xlApp = Nothing DoCmd.TransferSpreadsheet acImport, 8, tratablename, folderspec & "/" & f1.Name, True b = b + 1 Debug.Print f1.Name If b = 1 Then '第一次有数据导入后,将tratablename表的字段名赋值给数组 objRs.Open tratablename, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly, adCmdUnspecified Set objFields = objRs.Fields ReDim myArray(objFields.Count) For intloop = 0 To (objFields.Count - 1) myArray(intloop) = objFields.Item(intloop).Name Debug.Print objFields.Item(intloop).Name Next objRs.Close Set objRs = Nothing c = UBound(myArray()) End If Else xlApp.Workbooks(1).Save xlApp.Quit Set xlApp = Nothing End If End If Next If b > 0 Then Erase myArray Erase tempArray End If Debug.Print "共成功导入" & b & "个文件至表:" & tratablename Exit Function err1: If Not objRs Is Nothing Then If objRs.State = adStateOpen Then objRs.Close Set objRs = Nothing End If Set xlApp = Nothing If b > 0 Then Erase myArray Erase tempArray End If MsgBox Err.Source & "-->" & Err.Description End Function

加入自动追加字段名的代码，方便excel格式不是很规范的时候也能自动导入，函数调用方法：TransExcelToAccess("F:/temp", "tablename"),第一个参数是目录，第二个参数是access里的表名

Dim xlApp As Excel.Application 可以换成Dim xlApp As Object,这样就不需要引用Excel组件