自动将多个工作表上相同单元格中的数据复制到新工作表中

Question

我有一个 excel 工作簿，其中有很多工作表（150 多个）都命名为不同的日期，我想从每个工作表上的相同单元格复制数据并将数据粘贴到新工作表中的单独行中。我对 VBA 和宏真的很陌生。我尝试使用“录制宏”功能，但这需要我手动复制/粘贴和更新每张纸的代码。我正在寻找一种方法来为所有当前工作表和未来工作表自动执行此操作。这是我目前拥有的代码。感谢您的帮助。

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

Answer 1

你可以这样做：

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