ExcelVBA把Excel导入到Access中（TransferSpreadsheet）

ExcelVBA把Excel导入到Access中
（TransferSpreadsheet）
导入单个EXCEL文件
Sub Export_Sheet_Data_ToAccess()
Dim myFile As Variant
Dim AppAccess As New Access.Application
Dim wbPath As String
myFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
If VarType(myFile) = vbBoolean Then
MsgBox "CanCel by User!"
Exit Sub
End If
Application.ScreenUpdating = False
wbPath = ThisWorkbook.Path & "\"
With AppAccess
.OpenCurrentDatabase wbPath & "CheckIn.mdb", True
.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "data", myFile, True .CloseCurrentDatabase
End With
Application.ScreenUpdating = True
MsgBox myFile & Chr(10) & " Export is Done！"
Set AppAccess = Nothing
End Sub
导入多个EXCEL文件
Sub Export_MultiSheets_Data_T oAccess()
Dim myFiles As Variant, vItem As Variant
Dim AppAccess As New Access.Application
Dim wbPath As String
myFiles = Application.GetOpenFilename( _
"Excel Files (*.xls), *.xls", , "Select All Files", , True)
If VarType(myFiles) = vbBoolean Then
MsgBox "CanCel by User!"
Exit Sub
End If
Application.ScreenUpdating = False
wbPath = ThisWorkbook.Path & "\"
With AppAccess
.OpenCurrentDatabase wbPath & "CheckIn.mdb", True If IsArray(myFiles) Then
For Each vItem In myFiles
.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, "data", vItem, True Next
End If
.CloseCurrentDatabase
End With
Application.ScreenUpdating = True
MsgBox " Export is Done！"
Set AppAccess = Nothing
End Sub
导入一个工作簿下的所有工作表
Sub Export_Sheets_Data_T oAccess()
Dim myFile As Variant
Dim AppAccess As Access.Application
Dim wbPath As String
Dim objWb As Workbook
Dim rngData As Range
Dim lRow As Long
Dim lCol As Long
Dim arr() As Variant
Dim iSht As Integer
Set AppAccess = New Access.Application
myFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls") If VarType(myFile) = vbBoolean Then
MsgBox "CanCel by User!"
Exit Sub
End If
Application.ScreenUpdating = False
Set objWb = GetObject(myFile)
ReDim arr(1 To objWb.Sheets.Count)
For iSht = 1 To objWb.Sheets.Count
With objWb.Sheets(iSht)
lRow = .[a65536].End(xlUp).Row
lCol = .[iv1].End(xlT oLeft).Column
Set rngData = .Range(.Cells(1, 1), .Cells(lRow, lCol))
arr(iSht) = .Name & "!" & rngData.Address(0, 0)
End With
Next
objWb.Close False
Set objWb = Nothing
wbPath = ThisWorkbook.Path & "\"
With AppAccess
.OpenCurrentDatabase wbPath & "Database.mdb", True
For iSht = 1 To UBound(arr)
.DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _ "data", myFile, True, arr(iSht) Next
.CloseCurrentDatabase
End With
Application.ScreenUpdating = True
MsgBox myFile & Chr(10) & " Export is Done！" Set AppAccess = Nothing
End Sub。