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

 

[SkipVought]

Hi,

On these various sheets, all having the same headings in the same order and only one row of headings, does every table heading start in A1?

You seem to be combining the data into a new sheet, Combined, in the ActiveWorkbook. So by the end of the year you’ll have 52 workbooks or another way of stating the situation, similar data in 52 places. If it were me, I’d put ALL the data in ONE workbook/sheet with an additional column for a Week-Of date.

BTW, the answer to your question, change the StartRow [highlight #FCE94F]value[/highlight]...

 'Fill in the start row
    StartRow = [highlight #FCE94F]2[/highlight]

...assuming that the heading row is always in row 1.

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

 

[BxWill]

All of the 23 worksheets to be merged have the same headings in the same order and only one row of headings and the headings start at cell A1.

Yes, the current process have some flaws but they are tolerable at this point. Vast improvement on what was done previously!

Just to provide additional context, I take the data from the numerous worksheets and combine them. Then, I add additional data before saving as a pipe delimited file to be uploaded into a Sql Server Database using Bulk Insert.

Finally, A query to Sql Server from MS Excel-based templates for presentation/charts, etc.

Note, the MS Excel workbook is just a template to consolidate the vast amounts of data prior to importing to Sql Server Db.

Use of Awk and/or Python or R may be more effective than the use of MS Excel in certain instances but the current approach appears reasonably effective...

 

[SkipVought]

“pipe delimited file to be uploaded into a Sql Server Database using Bulk Insert.”

I understand your current approch. Thanks for the clarification.

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

 

[BxWill]

Upon revising the code, No headers are displayed.

 

[BxWill]

No headers are displayed along the first row nor throughout the data.

What modifications are needed to display just one header at the top - along row 1?

 

[SkipVought]

 'Fill in the start row
    [b]StartRow = 1[/b]
    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
            
‘......
       [b]StartRow = 2[/b]
    Next sh

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

 

[BxWill]

Headers are still dispersed within the data.

It appears that maybe after the first worksheet that is merged, I should use something like Used range and offset it by 1 row for all of the other worksheets that need to be merged.

 

[SkipVought]

Please post your code

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

 

[BxWill]

Revised code is below.

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 = 2
           
    '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
            Last = LastRow(DestSh)

            
            Set CopyRng = sh.Range("A1").CurrentRegion

            '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
        
        If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
        sh.Range("A1:BA1").Copy DestSh.Range("A1")
        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

 

[SkipVought]

You did not do what I instructed you to do!

    'Fill in the start row
    [b]StartRow = 1[/b]

    '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
            Last = LastRow(DestSh)

            
            Set CopyRng = sh.Range("A1").CurrentRegion

            '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
        
        If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
        sh.Range("A1:BA1").Copy DestSh.Range("A1")
        End If
        
        
        [b]StartRow = 2[/b]
    Next

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

 

[BxWill]

Appreciate the time and insight, but it did not work.

 

[SkipVought]

Please explain how it did not work.

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

 

[BxWill]

Stand corrected!

When I delete some of the worksheets that I want to merge and then delete all of the records except three or four in the remaining worksheets that I want to merge, the code works.

Then, going back and re-importing all of the worksheets that I want to merge into the workbook, re-running the code, then all of the data is imported to the "Combined" worksheet but there are no column headers at the top - along row 1.

Appreciate any further insight as to a resolution.

Using this

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
'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
'replace
            'Find the last row with data on the DestSh
            'Last = LastRow(DestSh)

            
            'Set CopyRng = sh.Range("A1").CurrentRegion
'replace


 '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))
            End If ' added this line



            '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
        
        'If WorksheetFunction.CountA(DestSh.UsedRange) = 0 Then
        'sh.Range("A1:BA1").Copy DestSh.Range("A1")
        'End If
        
        
        StartRow = 2
    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

 

[SkipVought]

Set up a test in my Excel. 3 sheets, each with data in column A
[pre]
Sheet1 Sheet2 Sheet3
1 11 111
2 22 222
3 33 333
4 44 444
5 55 555
6 66 666
77 777
888
999
[/pre]
So row 1 on the 3 sheets respectively is 1, 11, 111.

Here are the results in Combined using the last code you posted...
[pre]
1
2
3
4
5
6
22
33
44
55
66
77
222
333
444
555
666
777
888
999
[/pre]
NOTICE: I have 1, but not 11 or 111.

Seems to me that's what you're looking for unless I'm misunderstanding something.


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

 

[BxWill]

Great catch!

Is incrementing the variable, "StartRow = 2", resulting in the exclusion of the first row under the header for each of the worksheets to be merged (other than the first merged worksheet)?

I am interested in combining all of the records from the worksheets that should be merged.

The column header from the first worksheet that should be merged and all of the records.

 

[SkipVought]

StartRow is never incremented. It starts as 1 and is 2 thereafter.

???

My test demonstrates that your code gets row 1 on the first pass of the loop and omits row 1 thereafter.

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

 

[BxWill]

Noted.

Any insight as to the modifications needed to ensure that all of the data is merged into the worksheet "combined?

 

[SkipVought]

Is incrementing the variable, "StartRow = 2", resulting in the exclusion of the first row under the header for each of the worksheets to be merged (other than the first merged worksheet)?

That does not make sense with the code you supplied!

I ran your code without modification in my test workbook and row 2 data (2, 22, 222) from all sheets appears in the Combine sheet.

So your woakbook has some other sheet data configuration that you’re not revealing!

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

 

[SkipVought]

Can you upload your workbook?

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