CODEWITHSUNDEEP
vbaexcel
Vince
Vince

Reputation: 33

Loop through worksheets and paste code

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.

Upvotes: 0

Views: 139

Answers (2)

user3598756
user3598756

Reputation: 29421

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)

Upvotes: 0

David
David

Reputation: 1232

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!

Upvotes: 0

Related Questions