Read data from all sheets of  an  excel file using OPENROWSET

Sub Combine_Worksheets()
    Dim i As Integer, j As Integer
    Dim lstRow1 As Integer, lstRow2 As Integer, lstCol As Integer
    Dim ws1 As Worksheet, ws As Worksheet
    Dim wsMstr As String
    Dim LstCell As String
    Dim EMsg As String
    Dim DisplayMsg As String
    Dim ColCnt As Integer
    Dim CntFlg As Integer
    Dim Response As String
    Dim errorMsg As String

    On Error GoTo errHandler
    errFlag = False

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .StatusBar = False
    End With

    'Intitialize Variables
    wsMstr = "Master"       'Master Worksheet Name - rename as needed
    EMsg = ""
    CntFlg = 0
    Application.StatusBar = "Creating/Updating the " & wsMstr & " Worksheet with Current Data"

    Sheets(wsMstr).Activate
    With Range("A1", ActiveCell.SpecialCells(xlLastCell))
        .Clear
        .EntireRow.Delete
    End With

comeBack:
    Set ws1 = Sheets(wsMstr)
    lstRow2 = 1
    j = 1

    'Check the Number of Columns in each data worksheet
    'Set CntFlg to 1 if any sheet has a different number of columns
    ColCnt = Sheets(2).Cells(1, 16384).End(xlToLeft).Column
    For i = 2 To Sheets.Count
        If Right(Sheets(i).Name, 1) <> "+" Then
            Worksheets(i).Activate
            EMsg = EMsg & ActiveSheet.Cells(1, 16384).End(xlToLeft).Column & " Columns - " & Sheets(i).Name & Chr(10)
            If ColCnt <> ActiveSheet.Cells(1, 16384).End(xlToLeft).Column Then errFlag = True
        End If
    Next

    'IF CntFlag was set above, Display the Error Dialog and exit the routine
    If errFlag = True Then
        DisplayMsg = "The Component Sheets Do Not Have the Same Number of Columns" & Chr(10) & Chr(10)
        DisplayMsg = DisplayMsg & EMsg & Chr(10)
        DisplayMsg = DisplayMsg & "Correct the Sheets Before Continuing" & Chr(10) & "Routine is Exiting"
        Response = MsgBox(DisplayMsg, vbCritical, "wsMstr Column Count Error")
        GoTo finished
    End If

    'Combine the sheets
    For i = 2 To Sheets.Count
        If Right(Sheets(i).Name, 1) <> "+" Then
            Worksheets(i).Activate
            lstCol = ActiveSheet.Cells(1, 16384).End(xlToLeft).Column
            lstRow1 = ActiveSheet.Cells(65536, "A").End(xlUp).Row
            Range("A" & j, Cells(lstRow1, lstCol)).Copy
            With ws1.Range("A" & lstRow2)
                .PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                .PasteSpecial Paste:=xlPasteFormats
            End With
            Application.CutCopyMode = False
            lstRow2 = ws1.Cells(65536, "A").End(xlUp).Row + 1
            j = 2
        End If
    Next

    'Determine the Last Cell in the wsMstr worksheet
    LstCell = Worksheets(wsMstr).Cells.SpecialCells(xlCellTypeLastCell).Address

    With Sheets(wsMstr)
        .Activate
        .ListObjects.Add(xlSrcRange, Range("$A$1:" & LstCell), , xlYes).Name = "Tbl_Mstr"
        .Range("A1").Select
    End With

finished:

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        .StatusBar = False
    End With

    Exit Sub

errHandler:

    'If the wsMstr worksheet does not exist a Subscript out of Range error will
    'occur. Create the wsMstr worksheet and return / continue
    If Err.Number = 9 Then
        Sheets.Add Before:=Worksheets(1)
        ActiveSheet.Name = wsMstr
        Resume comeBack
    Else
        errorMsg = "An error has occurred." & Chr(10) & Chr(10) & Err.Number & " - -" & Err.Description
        MsgBox errorMsg, vbCritical, "Error Message - " & ThisWorkbook.Name
        Resume finished
    End If

End Sub

Select all Open in new window