VBA - Loop through sheets, copy used rows, insert as new rows in destination sheet in same workbook

[dcoker]

I am pretty new to VBA and am trying to get a macro running that will loop through all visible worksheets that do not include specific names ("Master", "Report")

Basically, I am wanting all used rows to be copied then inserted as new rows in sequence in the "Report" worksheet.
The code is only working for the first sheet, however there are two other worksheets visible that are named something different than above.

Any help is appreciated. Thank you.

Public Sub ConsolidateData()

Dim lRow As Long
Dim lDestRow As Long
Dim DestWS As Worksheet

lRow = Cells(Rows.Count, "A").End(xlUp).Row

lDestRow = Sheets("Report").Cells(Rows.Count, "A").End(xlUp).Row

Set DestWS = Sheets("Report")

  Dim ws As Worksheet
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Master" And ws.Visible <> False And ws.Name <> "Report" Then
           With ws
                      
           Range("A1:z" & lRow).Copy DestWS.Rows(lDestRow)
           End With
        
        
        
        End If
    Next ws


End Sub

 

[gordsky]

you need to put your ldestrow code inside the loop as Im assuming that each time you loop the ldestrow will have moved on by whatever was copied to the report sheet.
If the lrow isnt the same on all sheets you need to put that inside the loop as well

 

[dcoker]

you need to put your ldestrow code inside the loop as Im assuming that each time you loop the ldestrow will have moved on by whatever was copied to the report sheet.
If the lrow isnt the same on all sheets you need to put that inside the loop as well

Thanks gordsky

I was able to get it to work with this following code, but I ran into an issue since there are checkboxes that need to be copied over within a specific row that did not carry over. I had to manually set the first sheet's range ("Cover") to be copied then the rest would follow.

Sub Consolidate()

Dim lRow As Long
Dim lDestRow As Long
Dim DestWS As Worksheet


Dim ws As Worksheet

Set DestWS = Sheets("Report")


           Sheets("Cover").Range("A1:T55").Copy
           DestWS.Cells(1, 1).Insert
          
          

    
    For Each ws In ThisWorkbook.Worksheets
           lRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
         lDestRow = DestWS.Cells(Rows.Count, "A").End(xlUp).Row
        If ws.Name = "Master" Or ws.Name = "Report" Or ws.Name = "Cover" Then
           'do nothing
          
           ElseIf ws.Visible = True Then
          
          
           ws.Range("A2:T" & lRow + 1).Copy
           DestWS.Cells(Rows.Count, "A").End(xlUp).Insert Shift:=xlDown
        
        
        
        
        End If

    Next ws


End Sub

 

[gordsky]

Thanks gordsky

I was able to get it to work with this following code, but I ran into an issue since there are checkboxes that need to be copied over within a specific row that did not carry over. I had to manually set the first sheet's range ("Cover") to be copied then the rest would follow.

Sub Consolidate()

Dim lRow As Long
Dim lDestRow As Long
Dim DestWS As Worksheet


Dim ws As Worksheet

Set DestWS = Sheets("Report")


           Sheets("Cover").Range("A1:T55").Copy
           DestWS.Cells(1, 1).Insert
         
         

   
    For Each ws In ThisWorkbook.Worksheets
           lRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
         lDestRow = DestWS.Cells(Rows.Count, "A").End(xlUp).Row
        If ws.Name = "Master" Or ws.Name = "Report" Or ws.Name = "Cover" Then
           'do nothing
         
           ElseIf ws.Visible = True Then
         
         
           ws.Range("A2:T" & lRow + 1).Copy
           DestWS.Cells(Rows.Count, "A").End(xlUp).Insert Shift:=xlDown
       
       
       
       
        End If

    Next ws


End Sub

Glad you got it working, if your query is complete please markup resolved by placing tick next to the answer