MS Excel VBA - Merge certain worksheets into one worksheet 1

[BxWill]

Have workbook with 25 worksheets. I need to merge all of the worksheets except two worksheets ("EquipmentTest" and "CapitalTest") to a single worksheet named "Combined."


Note, The 23 remaining worksheets have the same column headers, same number of columns.


For any given week, the number of worksheets to merge varies and there is no way to know the specific names of the worksheets to be merged. One week, there can
be 25, another week - there may be 40 and so on.


Using the code below will merge the data onto one worksheet but there are column headers from each worksheet that are dispersed throughout the data.
Note, a column header at the very top of the data and multiple column headers throughout!

There should only be one column header on the worksheet "combined."

Attempting to modify but not successful so far.

Any insight as to how to resolve?

One thought was to include another variable to designate that the first worksheet other than the worksheets ""EquipmentTest" and "CapitalTest."

Then, while the variable = 1, copy the header columns, increment to "2" and then copy the current region for the remaining worksheets without the column header. Currently working on this approach but thought that there may be a more efficient method.

Thanks in advance.

Sub CopyDataFromSelectWorksheets()

    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long

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

    'Delete the sheet "Combined" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Combined").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "Combined"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Combined"

    
    
    'Fill in the start row
    StartRow = 1
    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
            

        If IsError(Application.Match(sh.Name, _
            Array(DestSh.Name, "EquipmentTest", "CapitalTest"), 0)) Then


            'Find the last row with data on the DestSh and sh
            Last = LastRow(DestSh)
            shLast = LastRow(sh)

            'If sh is not empty and if the last row >= StartRow copy the CopyRng
            If shLast > 0 And shLast >= StartRow Then

                'Set the range that you want to copy
                Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))

                'Test if there enough rows in the DestSh to copy all the data
                If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                    MsgBox "There are not enough rows in the Destsh"
                    GoTo ExitTheSub
                End If

               
                CopyRng.Copy
                With DestSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With

            End If

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

 

[BxWill]

Well,

Quite interesting observation is that if there is a query table on one of the worksheets, then the code does not work.

When I change the table to a normal range, the code works.

The query table will occur later in the process, after the data is merged into the "combined" worksheet.

The worksheet with the query table is sourced from another worksheet. This is the worksheet that I had planned to either download as a pipe delimited file to be bulk inserted into a Sql Server table or create a linked server.

Any insight as to the use of a linked server to load the Sql Server table relative to the use of bulk insert. (Currently, I am favoring the bulk insert process)

May need to start another thread...

 

[SkipVought]

Quite interesting observation is that if there is a query table on one of the worksheets, then the code does not work.

That ABSOLUTELY makes no sense.

Plz upload your workbook, query table and all. There must be something else going on.



Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]

 

[BxWill]

Not able to upload workbook due to confidentiality of the data and other code within.

Does not make sense to me but the code works after the table is converted.

 

[SkipVought]

I just added a QT to my test workbook. Runs like a top!

I see no relationship between QTs and your code not running properly.

If you could pare down and sanitize your workbook to the point where 1) the malfunction occurs and 2) it can be viewed without compromising your business, please upload that version.

But if you are saying that making the QTs normal tables "fixes" things, then just do that.

Skip,
[sub]
Just traded in my OLD subtlety...
for a NUance![/sub]