VBA, Copy rows from multple Worksheets to a master sheet

Question

I have a macro that does a calculation for all sheets in a workbook, I need to copy these results(which are located in the last row of each sheet, but each row may be different for each sheet) to a master sheet(as it needs to be done for multiple files), could anyone help alter my macro to do this or even make a new one?

If needed here is my macro:

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

mielk mielk · Accepted Answer · 2015-07-24T13:34:08

Below is the code to accomplish the task you have described. I put some comment, so you can understand what is going on. If you have any further questions regarding this code, ask in comment.

NOTE. There is one external function used in the code below so you need to include it in your code as well, otherwise it will not compile. Here is the code of this function - 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

EDIT

If you want to put the result into a new workbook instead of a new worksheet within the same workbook you need to replace this block of code:

    '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
    '---------------------------------------------------------------------------------

with this one:

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

VBA, Copy rows from multple Worksheets to a master sheet

1 Answers