[VBA] Link multiple Excel Sheets as Tables into Access Database

https://github.com/walter426/VbaUtilities/blob/master/ExcelUtilities.bas

Since the DoCmd.TransferSpreadsheet Method requires the range of the excel sheet to be linked, I wrote below function to find the used range of the sheet automatically, and do such linking of multiple sheets selected in the argument, "SheetNameList".
Besides, the local table name can also be user-defined in "SheetNameLocalList". If not, the default name in "SheetNameList" will be applied.
"ShtSeriesList" can be applied if there are multiple worksheets of the same type of name(e.g. "sample_1", "sample_2"), a generic pattern, "sample_*" can be used to indicated this kind of sheets for linking.
If the "HasFieldNames" is set as "True", the function will set the range stopped before the column of empty header to prevent from invalid header fault from Access

Code:

'Link multiple worksheets in workbooks
Public Function LinkToWorksheetInWorkbook(Wb_path As String, ByVal SheetNameList As Variant, Optional ByVal SheetNameLocalList As Variant, Optional ByVal ShtSeriesList As Variant, Optional HasFieldNames As Boolean = True) As String
    On Error GoTo Err_LinkToWorksheetInWorkbook

    Dim FailedReason As String

    If Len(Dir(Wb_path)) = 0 Then
        FailedReason = Wb_path
        GoTo Exit_LinkToWorksheetInWorkbook
    End If
    

    If VarType(SheetNameLocalList) <> vbArray + vbVariant Then
        SheetNameLocalList = SheetNameList
    End If
    

    'Prepare worksheets to be linked.
    If UBound(SheetNameList) <> UBound(SheetNameLocalList) Then
        FailedReason = "No. of elements in SheetNameList and SheetNameLocalList are not equal"
        GoTo Exit_LinkToWorksheetInWorkbook
    End If
    

    'Link worksheets
    Dim FullNameList() As Variant
    Dim SheetNameAndRangeList() As Variant

    Dim oExcel As Excel.Application
    Set oExcel = CreateObject("Excel.Application")
    
    With oExcel
        Dim oWb As Workbook
        Set oWb = .Workbooks.Open(Filename:=Wb_path, ReadOnly:=True)

        With oWb
            'Prepare to link worksheets in series
            If VarType(ShtSeriesList) = vbArray + vbVariant Then
            
                Dim ShtSeries As Variant
                
                Dim ShtSeries_name As String
                Dim ShtSeries_local_name As String
                Dim ShtSeries_start_idx As Integer
                Dim ShtSeries_end_idx As Integer
                
                Dim WsInS_idx As Integer
                Dim WsInS_cnt As Integer
                
                For Each ShtSeries In ShtSeriesList
                    ShtSeries_name = ShtSeries(0)
                    ShtSeries_local_name = ShtSeries(1)
                    ShtSeries_start_idx = ShtSeries(2)
                    ShtSeries_end_idx = ShtSeries(3)
                    
                    If ShtSeries_local_name = "" Then
                        ShtSeries_local_name = ShtSeries_name
                    End If
                    
                    
                    If ShtSeries_end_idx < ShtSeries_start_idx Then
                        ShtSeries_end_idx = .Worksheets.count - 1
                    End If
                    
                    
                    WsInS_cnt = 0
                
                    For WsInS_idx = ShtSeries_start_idx To ShtSeries_end_idx
                        If WorkSheetExist(oWb, Replace(ShtSeries_name, "*", WsInS_idx)) = True Then
                            WsInS_cnt = WsInS_cnt + 1
                        Else
                            Exit For
                        End If
                        
                    Next WsInS_idx
                
    
                    If WsInS_cnt > 0 Then
                        For WsInS_idx = 0 To WsInS_cnt
                            FailedReason = AppendArray(SheetNameList, Array(Replace(ShtSeries_name, "*", WsInS_idx)))
                            FailedReason = AppendArray(SheetNameLocalList, Array(Replace(ShtSeries_local_name, "*", WsInS_idx)))
                        Next WsInS_idx
                        
                    End If
                    
                Next ShtSeries
                
            End If
            
            'Link worksheets
            ReDim FullNameList(0 To UBound(SheetNameList))
            ReDim SheetNameAndRangeList(0 To UBound(SheetNameList))
    
            Dim SheetNameIdx As Integer
            Dim SheetName As String
            Dim FullName As String
            Dim ShtColCnt As Long
            Dim col_idx As Long
            Dim SheetNameAndRange As String

            For SheetNameIdx = 0 To UBound(SheetNameList)
                SheetName = SheetNameList(SheetNameIdx)
                DelTable (SheetNameLocalList(SheetNameIdx))
                  
                On Error Resume Next
                .Worksheets(SheetName).Activate
                On Error GoTo Next_SheetNameIdx_1
                
                With .ActiveSheet.UsedRange
                    ShtColCnt = .Columns.count
                    
                    If HasFieldNames = True Then
                        For col_idx = 1 To ShtColCnt
                            If IsEmpty(.Cells(1, col_idx)) = True Then
                                ShtColCnt = col_idx - 1
                                Exit For
                            End If
                        Next col_idx
                    End If
                    
                    SheetNameAndRange = SheetName & "!A1:" & ColumnLetter(oWb.ActiveSheet, ShtColCnt) & .Rows.count
                    
                End With '.ActiveSheet.UsedRange
                
                FullNameList(SheetNameIdx) = .FullName
                SheetNameAndRangeList(SheetNameIdx) = SheetNameAndRange
                
Next_SheetNameIdx_1:
            Next SheetNameIdx

            .Close False
            
        End With 'oWb
        
        .Quit
        
    End With 'oExcel
    

    For SheetNameIdx = 0 To UBound(SheetNameList)
        If SheetNameLocalList(SheetNameIdx) <> "" Then
            SheetName = SheetNameLocalList(SheetNameIdx)
        Else
            SheetName = SheetNameList(SheetNameIdx)
        End If
        
        FullName = FullNameList(SheetNameIdx)
        SheetNameAndRange = SheetNameAndRangeList(SheetNameIdx)

        DelTable(SheetName)
        
        On Error Resume Next
        DoCmd.TransferSpreadsheet acLink, , SheetName, FullName, True, SheetNameAndRange
        On Error GoTo Next_SheetNameIdx_2
        
Next_SheetNameIdx_2:
    Next SheetNameIdx
    
    On Error GoTo Err_LinkToWorksheetInWorkbook
    
    
Exit_LinkToWorksheetInWorkbook:
    LinkToWorksheetInWorkbook = FailedReason
    Exit Function

Err_LinkToWorksheetInWorkbook:
    FailedReason = Err.Description
    Resume Exit_LinkToWorksheetInWorkbook
    
End Function