Create a summary sheet with a macro

Question

Hi All

As a follow up to my previous question, can someone please assist.

My workbook has in excess of 100 worksheets.  Each worksheet has varying number of rows.

HansV was very helpful and provided me with a code which worked and created a subtotal row below the last entry on each worksheet, with totals appearing in columns G:L and a grand total row below the subtotal which totals the subtotals.

My next task is to create a summary. That is

• create a new worksheet labeled Summary
• Copy the values that appear in the subtotal row into columns B:G
• Copy the Sheet name into Column A

I tried the following macro code:

Sub Summary()

    Dim ws As Worksheet, x, a, n As Long

    Redim a(1 To Worksheets.Count, 1 To 2)

    For Each ws In Worksheets

        If ws.Name <> "Summary-Sheet" Then

            n = n + 1: a(n, 1) = ws.Name

            x = Application.Application.Match("Subtotal*", ws.Columns(1), 0)

            If IsNumeric(x) Then a(n, 2) = "='" & ws.Name & "'!G" & x

        End If

    Next

    On Error Resume Next

    Application.DisplayAlerts = False

    Sheets("Summary-Sheet").Delete

    Application.DisplayAlerts = False

    On Error Goto 0

    With Sheets.Add.[a1].Resize(n)

        .Columns(1).Value = a

        With .Columns(3)

            .Value = Application.Index(a, 0, 2)

            .AutoFill .Resize(, 6)

        End With

        .Parent.Columns.AutoFit

        .Parent.Name = "Summary-Sheet"

    End With

End Sub

The problem is, because the subtotal appears on row138 in the first worksheet of the workbook, the code looks for the subtotal row between row 1 and 138 for all sheets. It picks up the value of row138 and imports that even though the subtotal line is at row189. If the subtotal row is before row138 I have no problems. It is also creating additional sheets each to the number of worksheets currently in the workbook.

Please assist

Thank you

Derryn

Answer 1

Change that line to

                ws1.Cells(n, 2).Resize(, 6).Formula = "='" & ws.Name & "'!G" & x

Answer 2

Good Morning HansV

Thank you for the macro code.

I find that it copies the sheet name to column A of the new sheet, however it only copies the value fro column G.

How would I get it to copy all the columns from G to L?

I tried amending the line:

       ws1.Cells(n, 2).Formula = "='" & ws.Name & "'!G" & x

to

      ws1.Cells(n, 2).Formula = "='" & ws.Name & "'!G:L" & x

or

 ws1.Cells(n, 2).Formula = "='" & ws.Name & "'!G, H, I. J, L" & x

but it keeps giving me an error.

Regards

Derryn

Answer 3

I don't understand all of your code, but try this as starting point:

Sub Summary()

    Const sName = "Summary-Sheet"

    Dim ws As Worksheet, ws1 As Worksheet, x, n As Long

    Application.ScreenUpdating = False

    On Error Resume Next

    Set ws1 = Sheets(sName)

    On Error GoTo 0

    If ws1 Is Nothing Then

        Set ws1 = Worksheets.Add(Before:=Worksheets(1))

        ws1.Name = sName

    End If

    ws1.Cells.ClearContents

    For Each ws In Worksheets

        If ws.Name <> sName Then

            n = n + 1

            ws1.Cells(n, 1) = ws.Name

            x = Application.Application.Match("Subtotal*", ws.Columns(1), 0)

            If IsNumeric(x) Then

                ws1.Cells(n, 2).Formula = "='" & ws.Name & "'!G" & x

            End If

        End If

    Next ws

    ws1.Columns.AutoFit

    Application.ScreenUpdating = True

End Sub