多重导入/链接Excel文件进入带有调试信息和更多选项的访问权限-CSDN博客

在对数据库进行长时间测试之后，从第一个代码中升级了很多部分，我很高兴向大家展示我的Import / Link Excel vba代码，该代码非常有用且稳定。

函数（不是sub，因为我更喜欢在另一个函数中调用函数）

ImportMultiData（[链接]）

可以导入/链接具有其他选项的excel表：

选项 -链接-True =链接表，False =导入表，默认= False

尝试导入/链接3次后，Function将忽略该文件并继续。导入/链接后将提供错误导入文件的详细信息，ErrDebug.txt将在桌面上自动创建，以获取最新的导入错误。

使用以下第二功能自动修复损坏的Excel文件，称为

OpenExcelIdle（）

Option Compare Database
Option Explicit
Public Function ImportMultiData(Optional Link as Boolean)
'Owner: Hv summer -
'Original code found at:
'https://bytes.com/topic/access/insights/964941-multi-import-link-excel-file-into-access-debug-info-more-option#post3798690
'If you want to use/share this Code, plz keep my signature, thanks. 
'Enjoy it.
DoCmd.SetWarnings (False) 
On Error GoTo Err_F::
Dim strFolder As String, i As Integer, g As Integer, n As Integer, Try As Integer, TimesTry As Integer, M As Integer
Dim blnHasFieldNames As Boolean
Dim strFile As String, strArray() As String, strError As String, strErr As Integer, ListNameErr As String, ListErr As String
Dim strTable As String
Dim lngPos As Long
Dim strExtension As String
Dim lngFileType As Long
Dim strFullFileName As String
Dim ImportRange as String
g = 0 
'Change this to False if you data's range in excel don't have Field Names
blnHasFieldNames = True 
'Change this strTable to anytable name that you want to import
strTable = "DataTable" 
'Change this ImportRange to wherever your data's range in excel
ImportRange = "Data!B4:J64000" 
if ismissing(Link) then Link = False
With Application.FileDialog(3) ' msoFileDialogFilePicker
         .InitialFileName = "D:\"
        .AllowMultiSelect = True
        .Title = "Select Excel Files to Import"
If .Show Then
    For i = 1 To .SelectedItems.Count 
        strFullFileName = .SelectedItems(i) 
        If Right$(strFullFileName, 1) <> "\" And Len(strFullFileName) > 0 Then
            strArray = Split(strFullFileName, "\")
            strFile = strArray(UBound(strArray))
        End If 
        lngPos = InStrRev(strFile, ".")
        strExtension = Mid(strFile, lngPos + 1)
        Select Case strExtension
            Case "xls"
                lngFileType = acSpreadsheetTypeExcel9
            Case "xlsx"
                lngFileType = acSpreadsheetTypeExcel12Xml
            Case "xlsb", "xlsm"
                lngFileType = acSpreadsheetTypeExcel12
        End Select
        Try = 0
        M = 0
TryAgain::
        If Try = 3 Then GoTo NextI::
        If M > 0 Then Try = Try + 1
        If Link = False then
          DoCmd.TransferSpreadsheet acImport, lngFileType, strTable, strFullFileName, blnHasFieldNames, ImportRange
        Else
          DoCmd.TransferSpreadsheet acLink, lngFileType, strTable, strFullFileName, blnHasFieldNames, ImportRange        
        End If
        g = g + 1
        If Try > 0 Then TimesTry = TimesTry + Try
NextI::
    Next i 'Move to the next file
    If n > 0 Or TimesTry > 0 Then
            MsgBox "Number of Files selected: " & .SelectedItems.Count & ". Number of Files Imported: " & g - n & ". Err Num:" & n & vbNewLine & strError & vbNewLine & "Tried Times: " & TimesTry & vbNewLine & ListNameErr, vbInformation, "Finish Import"
    Else
            MsgBox "Number of Files selected: " & .SelectedItems.Count & ". Number of Files Imported: " & g - n, vbInformation, "Finish Import"
    End If 
    If Not n = 0 Then
        Dim TFS As Object
        Set TFS = CreateObject("Scripting.fileSystemobject")
        Dim textF As Object
        If Len(Dir("D:\ErrDebug.txt")) <> 0 Then Kill "D:\ErrDebug.txt"
        Set textF = TFS.createtextfile("D:\ErrDebug.txt")
        Set textF = Nothing
        Set TFS = Nothing
        Open "D:\ErrDebug.txt" For Output As #1
        Print #1, ListErr
        Close #1
        If Len(Dir(Environ("USERPROFILE") & "\Desktop\ErrDebug.txt")) <> 0 Then Kill Environ("USERPROFILE") & "\Desktop\ErrDebug.txt"
        Name "D:\ErrDebug.txt" As Environ("USERPROFILE") & "\Desktop\ErrDebug.txt"
    End If 
Else
        MsgBox "No file selected!", vbCritical
        Exit Function
    End If
End With 
DoCmd.SetWarnings (True) 
Exit_F:
Exit Function
Err_F:
n = n + 1
M = M + 1
Call OpenExcelIdle(strFullFileName, M) 
DoCmd.SetWarnings (True)
If strErr <> Err.Number Then
    strError = strError & Err.Number & ", " & Err.Description & " "
    strErr = Err.Number
End If
If M = 1 Then
ListNameErr = ListNameErr & strFile & ", "
ListErr = ListErr & strFullFileName & vbNewLine
End If
DoCmd.SetWarnings (False)
Resume TryAgain::
End Function 
'This code below is additional function (Required) to repair excel file automatically.
Public Function OpenExcelIdle(strFullFileName As String, Optional TimesTry As Integer)
On Error GoTo Err::
Dim xlapp As Object
Set xlapp = CreateObject("Excel.Application")
Dim books As Object
xlapp.EnableEvents = False
xlapp.AutomationSecurity = 3
xlapp.Visible = False
xlapp.DisplayAlerts = False
xlapp.screenupdating = False
If TimesTry = 0 Or IsMissing(TimesTry) Then
    xlapp.workbooks.Open strFullFileName
Else
    xlapp.workbooks.Open FileName:=strFullFileName, CorruptLoad:=1
End If 
Set books = xlapp.ActiveWorkBook 
books.Save
books.Close
xlapp.Quit
Exit_F::
Exit Function
Err:: 
xlapp.DisplayAlerts = True
xlapp.screenupdating = True
xlapp.Quit
Set books = Nothing
Set xlapp = Nothing
Resume Exit_F::
End Function