Excel VBA把Excel導入到Access中（TransferSpreadsheet)

Brian82 2011-04-11

展開全文

導入單個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