Thread: How to copy rows from various sheet into 1 rolling sheet

Hi all,

The following problem exists...
I have an Excel2003 file which contains various sheets. They are named like "aa Pegatron", "bb Pegatron" etc. These sheets can contain any number of lines with data (up to max 5000 lines). The sheets have all the same format / layout.
I now need a macro to pull the data of all non-empty lines in columns D, E, F, H and J from all these various sheets into 1 accumulated sheet named "Overall sheet".

What code do I need to use so that the macro would recognize the different sheetnames (whereby Pegatron is the fixed value but the aa, bb, cc etc in front of it will change in the sheetname) and whereby all lines in these sheets are copied into the overall sheet without overwriting any existing lines in that sheet.

Attached an example file for your reference.

Any help would be highly appreciated!!
Peter

In your actual sheet:

1) open the VBEditor (Alt-F11)
2) Insert an empty module (Insert > Module)
3) Paste in this macro code

Option Explicit

Sub CollectData()
Dim ws As Worksheet
Dim wsDest As Worksheet:  Set wsDest = ThisWorkbook.Sheets("Overall sheet")
Dim LR As Long
Application.ScreenUpdating = False

wsDest.Range("A2:A" & Rows.Count).EntireRow.Clear

    For Each ws In ThisWorkbook.Worksheets
        If InStr(ws.Name, "Pegatron") > 0 Then
            LR = ws.Range("A" & Rows.Count).End(xlUp).Row
            ws.Range("D2:F" & LR & ",H2:H" & LR & ",J2:J" & LR).Copy
            wsDest.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValuesAndNumberFormats
        End If
    Next ws

Application.ScreenUpdating = True
End Sub

4) Open the ThisWorkbook module and paste in this code:

Private Sub Workbook_Open()
    Call CollectData
End Sub

5) Open the Overall Sheet module and paste in this code:

Private Sub Worksheet_Activate()
    Call CollectData
End Sub

6) Close the editor and save your workbook


Now every time you open the workbook or bring up the Overall Sheet onscreen the data will refresh from every other sheet with the word "Pegatron" in the sheet name.

Try this, it will examine the imported data for errors in column A and delete those rows.

Option Explicit

Sub CollectData()
Dim ws As Worksheet
Dim wsDest As Worksheet:  Set wsDest = ThisWorkbook.Sheets("Overall sheet")
Dim LR As Long
Application.ScreenUpdating = False

wsDest.Range("A2:A" & Rows.Count).EntireRow.Clear

    For Each ws In ThisWorkbook.Worksheets
        If InStr(ws.Name, "Pegatron") > 0 Then
            LR = ws.Range("A" & Rows.Count).End(xlUp).Row
            ws.Range("D2:F" & LR & ",H2:H" & LR & ",J2:J" & LR).Copy
            wsDest.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValuesAndNumberFormats
        End If
    Next ws

Range("A2:A" & Rows.Count).SpecialCells(xlCellTypeConstants, xlErrors).EntireRow.Delete xlShiftUp
Range("A2").Select
If Range("A2") = "" Then Range("A2") = "no data"
Application.ScreenUpdating = True
End Sub