VBA，将多个工作表中的行复制到主工作表

Question

我有一个宏来计算工作簿中的所有工作表，我需要将这些结果（位于每个工作表的最后一行，但每个工作表的每一行可能不同）复制到主工作表（因为它需要为多个文件完成），任何人都可以帮助改变我的宏来执行此操作甚至创建一个新的吗？

如果需要，这是我的宏：

Sub Calculationallsheetsv2()
    'Calculation all sheets, even when there is only headers
    Dim xrng As Range, lrw As Long, lrng As Range, i As Long
    Dim LstCo As Long, ws As Worksheet

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    For Each ws In ActiveWorkbook.Worksheets
        With ws

            If Not Application.WorksheetFunction.CountA(.Cells) = 0 Then

                LstCo = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
                For i = 1 To LstCo
                    With .Columns(i)
                        .TextToColumns Destination:=.Cells(1, 1), DataType:=xlDelimited, TrailingMinusNumbers:=True
                    End With
                Next

                lrw = .Columns("A:Y").Find("*", , xlValues, , xlRows, xlPrevious).row
                If lrw = 1 Then lrw = 2
                Set lrng = .Range("A" & lrw + 2)

                With .Range("A2:A" & lrw)
                    lrng.Formula = "=COUNTA(" & .Address(0, 0) & ")/ROWS(" & .Address(0, 0) & ")"
                End With

                Set xrng = .Range(lrng, .Cells(lrng.row, LstCo))

                lrng.AutoFill xrng, Type:=xlFillDefault
                xrng.Style = "Percent"
            End If
        End With
    Next

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        Application.CalculateFull
    End With

End Sub

Answer 1

以下是完成您所描述任务的代码。我发表了一些评论，所以你可以理解发生了什么。如果您对此代码有任何疑问，请发表评论。

注意即可。下面的代码中使用了一个外部函数，因此您需要将它包含在代码中，否则将无法编译。以下是此函数的代码 - Function to find the last non-empty row in a given worksheet。

Sub Calculationallsheetsv2()
    'Calculation all sheets, even when there is only headers
    Const SUMMARY_SHEET_NAME As String = "Summary"
    '-----------------------------------------
    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim wksSummary As Excel.Worksheet
    Dim arrRow As Variant
    Dim lastRow As Long
    '-----------------------------------------

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    Set wkb = Excel.ActiveWorkbook

    'Create [Summary] worksheet. -----------------------------------------------------
    On Error Resume Next
    Set wksSummary = wkb.Worksheets(SUMMARY_SHEET_NAME)
    On Error GoTo 0

    If wksSummary Is Nothing Then
        Set wksSummary = wkb.Worksheets.Add
        wksSummary.Name = SUMMARY_SHEET_NAME
    End If
    '---------------------------------------------------------------------------------

    'Iterate through all the worksheets in the workbook [wkb].
    For Each wks In wkb.Worksheets

        'Check the name of currently checked worksheet to exclude [Summary] worksheet
        'from this process.
        If wks.Name <> SUMMARY_SHEET_NAME Then

            'Check if there are any non-empty cells in this worksheet.
            If Application.WorksheetFunction.CountA(wks.Cells) Then

                'Find the index number of the last empty row.
                lastRow = lastNonEmptyRow(wks)

                'Copy the content of this row into array.
                arrRow = wks.Rows(lastRow).EntireRow

                'Paste the content of [arrRow] array into the first empty
                'row of the [Summary] worksheet.
                With wksSummary
                    .Rows(lastNonEmptyRow(wksSummary) + 1).EntireRow = arrRow
                End With

            End If

        End If

    Next wks

    'Restore screen updating and automatic calculation
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        Call .CalculateFull
    End With

End Sub

修改

如果要将结果放入新工作簿而不是同一工作簿中的新工作表，则需要替换此代码块：

    'Create [Summary] worksheet. -----------------------------------------------------
    On Error Resume Next
    Set wksSummary = wkb.Worksheets(SUMMARY_SHEET_NAME)
    On Error GoTo 0

    If wksSummary Is Nothing Then
        Set wksSummary = wkb.Worksheets.Add
        wksSummary.Name = SUMMARY_SHEET_NAME
    End If
    '---------------------------------------------------------------------------------

这一个：

    'Create [Summary] worksheet. -----------------------------------------------------
    Dim wkbSummary As Excel.Workbook
    Set wkbSummary = Excel.Workbooks.Add
    Set wksSummary = wkbSummary.Worksheets.Add
    wksSummary.Name = SUMMARY_SHEET_NAME
    '---------------------------------------------------------------------------------