VBA Combine all sheets into one

[rplohocky]

Hello,
I have ben using this code to combine all the sheets in one workbook into one sheet then delete the all but the combined one. It has been working fine but I just found out that if there is just a header row it copies the header row into the combined sheet. I don't want any header rows brought into the combined sheet, it does not doit on any of the sheets with data in rows 2 and beyond only the blank sheets.

Can anyone see how to modify this code to not take the header row or ignore the sheets that don't have data in row 2 and beyond?

Sub CombineTabsInventoryReports()
'this macro will combine all sheets within a WB into one sheet
'Make sure that all header rows on all tabs are identical.

    Dim J As Integer
    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add
    Sheets(1).Name = "Combined"
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")
    For J = 2 To Sheets.Count
    Sheets(J).Activate
    Range("A1").Select
    Selection.CurrentRegion.Select
    Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
    Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
    Next

'This section will delete all tabs but the combined one
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each xWs In Application.ActiveWorkbook.Worksheets
        If xWs.Name <> "Combined" Then
            xWs.Delete
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

 

[tonyyy]

rplohocky,

You might consider adding the rows in red...

Sub CombineTabsInventoryReports()
'this macro will combine all sheets within a WB into one sheet
'Make sure that all header rows on all tabs are identical.

    Dim J As Integer
    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add
    Sheets(1).Name = "Combined"
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")
    
    For J = 2 To Sheets.Count
        Sheets(J).Activate
        Range("A1").Select
        Selection.CurrentRegion.Select
        [COLOR=#ff0000]If Selection.Rows.Count > 1 Then[/COLOR]
            Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
            Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
        [COLOR=#ff0000]End If[/COLOR]
    Next

'This section will delete all tabs but the combined one
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each xWs In Application.ActiveWorkbook.Worksheets
        If xWs.Name <> "Combined" Then
            xWs.Delete
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

Cheers,

tonyyy

 

[vcoolio]

Hello rplohocky,

Besides what Tonyyy has suggested, you could trim the code down further as follows:-

Sub Combine()

        Dim ws As Worksheet, ws1 As Worksheet
        Set ws1 = Sheets("Combined")

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each ws In Worksheets
        If ws.Name <> "Combined" Then
        ws.UsedRange.Offset(1).Copy ws1.Range("A" & Rows.Count).End(3)(2)
        ws.Delete
        End If
Next ws

Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

It assumes that the "Combined" sheet already exists.


I hope that this helps,

Cheerio,
vcoolio.

 

[rplohocky]

rplohocky,

You might consider adding the rows in red...

Sub CombineTabsInventoryReports()
'this macro will combine all sheets within a WB into one sheet
'Make sure that all header rows on all tabs are identical.

    Dim J As Integer
    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add
    Sheets(1).Name = "Combined"
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")
    
    For J = 2 To Sheets.Count
        Sheets(J).Activate
        Range("A1").Select
        Selection.CurrentRegion.Select
        [COLOR=#ff0000]If Selection.Rows.Count > 1 Then[/COLOR]
            Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
            Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
        [COLOR=#ff0000]End If[/COLOR]
    Next

'This section will delete all tabs but the combined one
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each xWs In Application.ActiveWorkbook.Worksheets
        If xWs.Name <> "Combined" Then
            xWs.Delete
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

Cheers,

tonyyy

Hello Tonyyy,
Thanks for the help! I inserted those lines in the code but now I the only thing that gets copied is one header row, none of the other rows of data from the other 14 workbooks gets copied over to the combined sheet.

 

[rplohocky]

Hello Tonyyy,
Thanks for the help! I inserted those lines in the code but now I the only thing that gets copied is one header row, none of the other rows of data from the other 14 workbooks gets copied over to the combined sheet.

Tonyyy,
Nevermind!!! My mistake I inserted the code 1 line above where it should have been. I fixed it and now it works great thanks again for your help!!

 

[tonyyy]

You're very welcome...