Automate copying data from the same cells on multiple worksheets into a new worksheet

Question

I have an excel workbook that has a lot of worksheets (150+) all named as different dates, and I want to copy data from the same cells on each worksheet and paste the data into separate rows in a new sheet. I am really new to VBA and Macros. I tried using the "Record Macro" feature, but that requires me to manually copy/paste and update the code for each sheet. I am looking for a way to automate this for all current sheets as well as future sheets. Here is the code that I currently have. Thank you for any help.

Sub DataCopy()
'
' DataCopy Macro
'
'
    Range("'Summary'!B10").Select
    ActiveCell = "='02_10_2017'!C14"
    Range("C10").Select
    ActiveCell = "='02_10_2017'!D5"
    Range("D10").Select
    ActiveCell = "='02_10_2017'!E14"
    Range("E10").Select
    ActiveCell = "='02_10_2017'!F14"
    Range("F10").Select
    ActiveCell = "='02_10_2017'!G14"
    Range("G10").Select
    ActiveCell = "='02_10_2017'!J11"
    Range("H10").Select
    ActiveCell = "='02_10_2017'!K11"
    Range("I10").Select
    ActiveCell = "='02_10_2017'!J26"
    Range("J10").Select
    ActiveCell = "='02_10_2017'!K26"
    Range("K10").Select
    ActiveCell = "='02_10_2017'!C18"
    Range("L10").Select
    ActiveCell = "='02_10_2017'!E18"
    Range("M10").Select
    ActiveCell = "='02_10_2017'!C19"
    Range("N10").Select
    ActiveCell = "='02_10_2017'!E19"
    Range("O10").Select
    ActiveCell = "='02_10_2017'!C20"
    Range("P10").Select
    ActiveCell = "='02_10_2017'!C20"
    Range("Q10").Select
    ActiveCell = "='02_10_2017'!C21"
    Range("R10").Select
    ActiveCell = "='02_10_2017'!E21"
    Range("S10").Select
    ActiveCell = "='02_10_2017'!J29"
    Range("T10").Select
    ActiveCell = "='02_10_2017'!J30"

    Range("'Summary'!B11").Select
    ActiveCell = "='02_17_2017'!C14"
    Range("C11").Select
    ActiveCell = "='02_17_2017'!D5"
    Range("D11").Select
    ActiveCell = "='02_17_2017'!E14"
    Range("E11").Select
    ActiveCell = "='02_17_2017'!F14"
    Range("F11").Select
    ActiveCell = "='02_17_2017'!G14"
    Range("G11").Select
    ActiveCell = "='02_17_2017'!J11"
    Range("H11").Select
    ActiveCell = "='02_17_2017'!K11"
    Range("I11").Select
    ActiveCell = "='02_17_2017'!J26"
    Range("J11").Select
    ActiveCell = "='02_17_2017'!K26"
    Range("K11").Select
    ActiveCell = "='02_17_2017'!C18"
    Range("L11").Select
    ActiveCell = "='02_17_2017'!E18"
    Range("M11").Select
    ActiveCell = "='02_17_2017'!C19"
    Range("N11").Select
    ActiveCell = "='02_17_2017'!E19"
    Range("O11").Select
    ActiveCell = "='02_17_2017'!C20"
    Range("P11").Select
    ActiveCell = "='02_17_2017'!C20"
    Range("Q11").Select
    ActiveCell = "='02_17_2017'!C21"
    Range("R11").Select
    ActiveCell = "='02_17_2017'!E21"
    Range("S11").Select
    ActiveCell = "='02_17_2017'!J29"
    Range("T11").Select
    ActiveCell = "='02_17_2017'!J30"

End Sub

Did you know that Range("'Summary'!B10").Formula = "='02_10_2017'!C14" does the same thing as selecting it, and is a lot faster? — braX

Tim Williams Tim Williams · Accepted Answer · 2020-02-24T21:54:31

You can do something like this:

Sub DataCopy()

    Dim wsSummary As Worksheet, wsSource As Worksheet, wb As Workbook
    Dim arrCells, rw As Range, i As Long, rng

    Set wb = ActiveWorkbook
    Set wsSummary = wb.Sheets("Summary")

    Set rw = wsSummary.Rows(2) 'start here
    arrCells = Array("C14", "D5", "E14", "F14") 'etc: the cells you want to copy, in order

    'loop over all the worksheets
    For Each wsSource In wb.Worksheets
        'exclude the summary sheet
        If wsSource.Name <> wsSummary.Name Then
            rw.Cells(1).Value = wsSource.Name 'record the source sheet
            'loop over the source cells on the sheet
            For i = 0 To UBound(arrCells)
                rng = arrCells(i)
                'if have a cell address, copy the value (skip a column if blank)
                If rng <> "" Then rw.Cells(2 + i).Value = wsSource.Range(rng).Value
            Next i
            Set rw = rw.Offset(1, 0) 'next summary row
        End If
    Next wsSource

End Sub

Automate copying data from the same cells on multiple worksheets into a new worksheet

1 Answers