Attribute VB_Name = "OneClickSheetSummary"
Option Explicit

' MacroWise Starter Kit
' Macro 3: Create a one-click summary sheet
' Compatible with Excel 2016+

Private Const SUMMARY_SHEET_NAME As String = "Sheet Summary"

Public Sub CreateWorkbookSummary()
    Dim summarySheet As Worksheet
    Dim sourceSheet As Worksheet
    Dim outputRow As Long
    Dim amountTotal As Double
    Dim debitTotal As Double
    Dim creditTotal As Double
    Dim balanceTotal As Double
    Dim grandNumericTotal As Double
    Dim sheetCount As Long

    On Error GoTo CleanFail

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set summarySheet = PrepareSummarySheet(ThisWorkbook, SUMMARY_SHEET_NAME)
    WriteSummaryHeaders summarySheet
    outputRow = 2

    For Each sourceSheet In ThisWorkbook.Worksheets
        If sourceSheet.Name <> SUMMARY_SHEET_NAME Then
            If WorksheetFunction.CountA(sourceSheet.Cells) > 0 Then
                sheetCount = sheetCount + 1
                amountTotal = SumMatchingColumns(sourceSheet, Array("amount", "value"))
                debitTotal = SumMatchingColumns(sourceSheet, Array("debit", "withdrawal"))
                creditTotal = SumMatchingColumns(sourceSheet, Array("credit", "deposit"))
                balanceTotal = SumMatchingColumns(sourceSheet, Array("balance"))
                grandNumericTotal = SumAllNumericCells(sourceSheet)

                summarySheet.Hyperlinks.Add Anchor:=summarySheet.Cells(outputRow, 1), _
                    Address:="", SubAddress:="'" & sourceSheet.Name & "'!A1", TextToDisplay:=sourceSheet.Name

                summarySheet.Cells(outputRow, 2).Value = LastUsedRow(sourceSheet)
                summarySheet.Cells(outputRow, 3).Value = LastUsedColumn(sourceSheet)
                summarySheet.Cells(outputRow, 4).Value = WorksheetFunction.Max(LastUsedRow(sourceSheet) - DetectHeaderRow(sourceSheet, 10), 0)
                summarySheet.Cells(outputRow, 5).Value = CountNumericCells(sourceSheet)
                summarySheet.Cells(outputRow, 6).Value = grandNumericTotal
                summarySheet.Cells(outputRow, 7).Value = amountTotal
                summarySheet.Cells(outputRow, 8).Value = debitTotal
                summarySheet.Cells(outputRow, 9).Value = creditTotal
                summarySheet.Cells(outputRow, 10).Value = balanceTotal
                summarySheet.Cells(outputRow, 11).Value = Now

                outputRow = outputRow + 1
            End If
        End If
    Next sourceSheet

    FormatSummarySheet summarySheet, outputRow - 1

    MsgBox sheetCount & " worksheet(s) summarised on the '" & SUMMARY_SHEET_NAME & "' tab.", vbInformation, "MacroWise"

CleanExit:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Exit Sub

CleanFail:
    MsgBox "Summary generation stopped: " & Err.Description, vbCritical, "MacroWise"
    Resume CleanExit
End Sub

Private Function PrepareSummarySheet(ByVal wb As Workbook, ByVal sheetName As String) As Worksheet
    Dim ws As Worksheet

    On Error Resume Next
    Set ws = wb.Worksheets(sheetName)
    On Error GoTo 0

    If ws Is Nothing Then
        Set ws = wb.Worksheets.Add(Before:=wb.Worksheets(1))
        ws.Name = sheetName
    Else
        ws.Cells.Clear
    End If

    Set PrepareSummarySheet = ws
End Function

Private Sub WriteSummaryHeaders(ByVal ws As Worksheet)
    Dim headers As Variant
    Dim columnIndex As Long

    headers = Array("Worksheet", "Last Used Row", "Last Used Column", "Data Rows", _
                    "Numeric Cells", "Grand Numeric Total", "Amount Total", _
                    "Debit Total", "Credit Total", "Balance Total", "Generated At")

    For columnIndex = LBound(headers) To UBound(headers)
        ws.Cells(1, columnIndex + 1).Value = headers(columnIndex)
    Next columnIndex

    With ws.Range("A1:K1")
        .Font.Bold = True
        .Interior.Color = RGB(45, 90, 61)
        .Font.Color = RGB(255, 255, 255)
        .HorizontalAlignment = xlCenter
    End With
End Sub

Private Sub FormatSummarySheet(ByVal ws As Worksheet, ByVal lastRow As Long)
    If lastRow < 1 Then Exit Sub

    ws.Columns("A:K").AutoFit
    ws.Rows(1).RowHeight = 22
    ws.Range("F2:J" & lastRow).NumberFormat = "#,##0.00_);(#,##0.00)"
    ws.Range("K2:K" & lastRow).NumberFormat = "dd-mmm-yyyy hh:mm"

    If lastRow >= 2 Then
        ws.Range("A1:K" & lastRow).AutoFilter
    End If
End Sub

Private Function SumMatchingColumns(ByVal ws As Worksheet, ByVal patterns As Variant) As Double
    Dim headerRow As Long
    Dim lastRow As Long
    Dim lastCol As Long
    Dim columnIndex As Long
    Dim pattern As Variant
    Dim headerText As String
    Dim rowIndex As Long

    headerRow = DetectHeaderRow(ws, 10)
    lastRow = LastUsedRow(ws)
    lastCol = LastUsedColumn(ws)

    For columnIndex = 1 To lastCol
        headerText = LCase$(Trim$(CStr(ws.Cells(headerRow, columnIndex).Value)))
        For Each pattern In patterns
            If InStr(1, headerText, CStr(pattern), vbTextCompare) > 0 Then
                For rowIndex = headerRow + 1 To lastRow
                    If IsNumeric(ws.Cells(rowIndex, columnIndex).Value) Then
                        SumMatchingColumns = SumMatchingColumns + CDbl(ws.Cells(rowIndex, columnIndex).Value)
                    End If
                Next rowIndex
                Exit For
            End If
        Next pattern
    Next columnIndex
End Function

Private Function SumAllNumericCells(ByVal ws As Worksheet) As Double
    Dim cell As Range

    For Each cell In ws.UsedRange.Cells
        If IsNumeric(cell.Value) Then
            SumAllNumericCells = SumAllNumericCells + CDbl(cell.Value)
        End If
    Next cell
End Function

Private Function CountNumericCells(ByVal ws As Worksheet) As Long
    Dim cell As Range

    For Each cell In ws.UsedRange.Cells
        If IsNumeric(cell.Value) Then
            CountNumericCells = CountNumericCells + 1
        End If
    Next cell
End Function

Private Function DetectHeaderRow(ByVal ws As Worksheet, ByVal searchRows As Long) As Long
    Dim rowIndex As Long
    Dim populatedCells As Long
    Dim bestRow As Long
    Dim bestCount As Long

    For rowIndex = 1 To WorksheetFunction.Min(searchRows, ws.Rows.Count)
        populatedCells = WorksheetFunction.CountA(ws.Rows(rowIndex))
        If populatedCells > bestCount Then
            bestCount = populatedCells
            bestRow = rowIndex
        End If
    Next rowIndex

    DetectHeaderRow = bestRow
End Function

Private Function LastUsedRow(ByVal ws As Worksheet) As Long
    Dim lastCell As Range

    On Error Resume Next
    Set lastCell = ws.Cells.Find(What:="*", After:=ws.Range("A1"), LookIn:=xlFormulas, _
                                 SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    On Error GoTo 0

    If lastCell Is Nothing Then
        LastUsedRow = 0
    Else
        LastUsedRow = lastCell.Row
    End If
End Function

Private Function LastUsedColumn(ByVal ws As Worksheet) As Long
    Dim lastCell As Range

    On Error Resume Next
    Set lastCell = ws.Cells.Find(What:="*", After:=ws.Range("A1"), LookIn:=xlFormulas, _
                                 SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
    On Error GoTo 0

    If lastCell Is Nothing Then
        LastUsedColumn = 0
    Else
        LastUsedColumn = lastCell.Column
    End If
End Function