利润中心是什么:Excel VBA把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_ToAccess()
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_ToAccess()
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(xlToLeft).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