从各种（特定）工作表汇总到一个工作表

Question

在同一个工作簿中，我要做的就是从几个选定工作表中的单元格 B2 中复制值，然后粘贴到另一个名为“摘要”的工作表中的 D 列中。另外，我还想把对应的工作表名称复制粘贴到C列中.我是 VBA 新手。我相信你会发现愚蠢的错误，请原谅我。两个代码都在“运行时错误'5'：无效的过程调用或参数”下失败。非常感谢任何帮助。

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

Sub CopyRangeFromMultiWorksheets()
    Dim sh As Worksheet
    Dim wb As Workbook
    Dim DestSh As Worksheet

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wb = ThisWorkbook
    Set DestSh = wb.Sheets("Summary")

    ' Loop through worksheets that start with the name "20"
    ' This section I tested and it works

    For Each sh In ActiveWorkbook.Worksheets
        If LCase(Left(sh.Name, 2)) = "20" Then

            ' Specify the range to copy the data
            ' This portion has also been tested and it works

            sh.Range("B2").Copy

            ' Paste copied range into "Summary" worksheet in Column D
            ' This is the part that does not work I get:
            ' Run-time error '5' :  Invalid procedure call or argument

            With DestSh.Cells("D2:D")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

            ' This statement will copy the sheet names in the C column.
            ' I have not been able to check this part since I am stock in the previous step
            DestSh.Cells("C2:C").Resize(CopyRng.Rows.Count).Value = sh.Name

        End If

    Next

ExitTheSub:

    Application.Goto Worksheets("Summary").Cells(1)


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

第二个代码：

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

Sub CopyRangeFromMultiWorksheets()
    Dim sh As Worksheet

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    ' Loop through worksheets that start with the name "20"
    ' This section I tested and it works

    For Each sh In ActiveWorkbook.Worksheets
        If LCase(Left(sh.Name, 2)) = "20" Then

            ' Specify the range to copy the data
            ' This portion has also been tested and it works

            sh.Range("B2").Copy

            ' Paste copied range into "Summary" worksheet in Column D
            ' This is the part that does not work I get:
            ' Run-time error '5' :  Invalid procedure call or argument

            Worksheets("Summary").Cells("D2:D").PasteSpecial (xlPasteValues)

            ' This statement will copy the sheet names in the C column.
            ' I have not been able to check this part works since I am stock in the previous step
            Worksheets("Summary").Cells("C2:C").Resize(CopyRng.Rows.Count).Value = sh.Name



        End If

    Next

ExitTheSub:

    Application.Goto Worksheets("Summary").Cells(1)


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Answer 1

我已对您的第一个代码进行了更改：

    Sub CopyRangeFromMultiWorksheets()
        Dim sh As Worksheet
        Dim wb As Workbook
        Dim DestSh As Worksheet
        Dim LastRow As Long

        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

        Set wb = ThisWorkbook
        Set DestSh = wb.Sheets("Summary")

        ' Loop through worksheets that start with the name "20"
        ' This section I tested and it works

        For Each sh In ActiveWorkbook.Worksheets
            If LCase(Left(sh.Name, 2)) = "20" Then

                ' Specify the range to copy the data
                ' This portion has also been tested and it works

                sh.Range("B2").Copy

                LastRow = DestSh.Cells(Rows.Count, "D").End(xlUp).Row + 1   'find the last row of column "D"

                ' Paste copied range into "Summary" worksheet in Column D
                ' This is the part that does not work I get:
                ' Run-time error '5' :  Invalid procedure call or argument

                'With DestSh.Cells("D2:D")      ----> this line is giving error
                With DestSh.Cells(LastRow, 4)  '----> 4 is for Column "D"
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With

                ' This statement will copy the sheet names in the C column.
                ' I have not been able to check this part since I am stock in the previous step

                LastRow = DestSh.Cells(Rows.Count, "C").End(xlUp).Row + 1   'find the last row of column "C"

                'DestSh.Cells("C2:C").Resize(CopyRng.Rows.Count).Value = sh.Name    ----> this line is giving error
                DestSh.Cells(LastRow, 3).Value = sh.Name                   '----> 3 is for Column "C"

            End If
        Next
    ExitTheSub:
        Application.Goto Worksheets("Summary").Cells(1)
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End Sub