Loop through worksheets and paste code - vba

Question

Hi I have code which is meant to
Loop through all worksheets which begin with "673"
Copy all the rows which have data from row 5 onwards
Paste the entries on the next empty row in the "Colours" worksheet
I'm having the following issues:
Code only runs in the worksheet that is active
Doesn't loop through all worksheets
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)