Loop through worksheets and paste code

Question

Hi I have code which is meant to

1. Loop through all worksheets which begin with "673"
2. Copy all the rows which have data from row 5 onwards
3. Paste the entries on the next empty row in the "Colours" worksheet

I'm having the following issues:

1. Code only runs in the worksheet that is active
2. Doesn't loop through all worksheets

3. When it pastes in the "Colours" worksheet, it pastes directly over the headings in row 2. The first blank row is row 3 onwards and I would like the logic to paste at the next available blank row as it loops through the sheets.

   Sub Consolidate()
   
   Dim lastrow As Long
   Dim report As Worksheet
   Set report = Excel.ActiveSheet
   
   For Each Sheet In ActiveWorkbook.Worksheets
       If InStr(Sheet.Name, "673") > 0 Then      
   
           With report
               .Range(.Cells(5, "K"), .Cells(.Rows.Count, "K").End
               (xlUp)).EntireRow.Copy
           End With
   
           Worksheets("Colours").Select
   
           lastrow = Worksheets("Colours").Cells(Worksheets("Colours").Rows.Count, 1).End(xlUp).Row
   
           Worksheets("Colours").Cells(lastrow + 1, 1).Select
           ActiveSheet.Paste  
   
       End If
   Next
   End Sub
   

Your help would be greatly appreciated.

Answer 1

KS is right, to get your code functioning you just need to reference the sheet. I'd started modifying it further so I'll post what I've done in totality:

Firstly I removed the 'Set report = ' line, that's not needed (alternatively you could have 'Set report' at the beginning of the loop, but it's easier to work directly 'With Sheet' as KS says).

CHANGED1 = You said it should loop through worksheets that 'begin' with 673, so this new line checks for the first three characters matching 673, rather than just looking to see if 673 appears anywhere in the sheet name.

NEW = Activates the sheet, this makes the next copy command work.

CHANGED2 = With Sheet as explained above.

CHANGED3 = You said it should copy the rows that have data from row 5 onwards (previously your code would copy rows 1-5).

Sub Consolidate()
    Dim lastrow As Long
    Dim report As Worksheet

    For Each Sheet In ActiveWorkbook.Worksheets
        If Left(Sheet.Name, 3) = "673" Then 'CHANGED1

            Worksheets(Sheet.Name).Select 'NEW

            With Sheet 'CHANGED2
                .Range("A5", Range("A" & 65536).End(xlUp)).EntireRow.Copy 'CHANGED3
            End With

            Worksheets("Colours").Select

            lastrow = Worksheets("Colours").Cells(Worksheets("Colours").Rows.Count, 1).End(xlUp).Row

            Worksheets("Colours").Cells(lastrow + 1, 1).Select
            ActiveSheet.Paste

        End If
    Next
End Sub

Hope this helps!

Answer 2

try the following code

Sub Consolidate()    
Dim sheet As Worksheet, coloursSheet As Worksheet

Set coloursSheet = ActiveWorkbook.Worksheets("Colours")

For Each sheet In ActiveWorkbook.Worksheets
    If Left(sheet.Name, 3) = "673" Then
        sheet.Range("K5:K" & sheet.Cells(sheet.Rows.Count, "K").End(xlUp).Row).SpecialCells(xlCellTypeConstants).EntireRow.Copy _
        Destination:=coloursSheet.Cells(coloursSheet.Rows.Count, "A").End(xlUp).Offset(1)
    End If
Next
End Sub

it:

• avoids useless selections and variables

• copies non blank cells only (assuming data are "constants", i.e. not formulas)