VBA Code Templates

Ready-to-use VBA templates for common automation tasks. Copy and customize.

Load scenes/vba.md first for code standards and injection workflow.

Template 1: Auto-Generate Monthly Report

Option Explicit

' ============================================================
' Module: ModMonthlyReport
' Purpose: Auto-generate monthly summary from raw data sheet
' ============================================================

Public Sub GenerateMonthlyReport()
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim wsData As Worksheet
    Dim wsSummary As Worksheet
    Dim lastRow As Long
    Dim reportMonth As String
    
    ' Get target month
    reportMonth = InputBox("Enter month (YYYY-MM):", "Report Month", Format(Date, "YYYY-MM"))
    If reportMonth = "" Then GoTo CleanUp
    
    ' Reference sheets
    Set wsData = ThisWorkbook.Sheets("Data")
    
    ' Create or clear summary sheet
    On Error Resume Next
    Set wsSummary = ThisWorkbook.Sheets("Summary_" & reportMonth)
    On Error GoTo ErrHandler
    
    If wsSummary Is Nothing Then
        Set wsSummary = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsSummary.Name = "Summary_" & reportMonth
    Else
        wsSummary.Cells.Clear
    End If
    
    lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    
    ' Write headers
    wsSummary.Range("A1").Value = "Monthly Report: " & reportMonth
    wsSummary.Range("A1").Font.Size = 16
    wsSummary.Range("A1").Font.Bold = True
    
    wsSummary.Range("A3").Value = "Category"
    wsSummary.Range("B3").Value = "Total Amount"
    wsSummary.Range("C3").Value = "Count"
    wsSummary.Range("D3").Value = "Average"
    
    ' Aggregate by category (using Dictionary)
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    Dim i As Long
    Dim cat As String
    Dim amt As Double
    
    For i = 2 To lastRow
        ' Filter by month (assuming date in column A, category in B, amount in C)
        If Format(wsData.Cells(i, 1).Value, "YYYY-MM") = reportMonth Then
            cat = CStr(wsData.Cells(i, 2).Value)
            amt = CDbl(wsData.Cells(i, 3).Value)
            
            If dict.Exists(cat) Then
                dict(cat) = Array(dict(cat)(0) + amt, dict(cat)(1) + 1)
            Else
                dict.Add cat, Array(amt, 1)
            End If
        End If
    Next i
    
    ' Write results
    Dim outRow As Long
    outRow = 4
    Dim key As Variant
    For Each key In dict.Keys
        wsSummary.Cells(outRow, 1).Value = key
        wsSummary.Cells(outRow, 2).Value = dict(key)(0)
        wsSummary.Cells(outRow, 2).NumberFormat = "#,##0.00"
        wsSummary.Cells(outRow, 3).Value = dict(key)(1)
        wsSummary.Cells(outRow, 4).Value = dict(key)(0) / dict(key)(1)
        wsSummary.Cells(outRow, 4).NumberFormat = "#,##0.00"
        outRow = outRow + 1
    Next key
    
    ' Auto-fit columns
    wsSummary.Columns("A:D").AutoFit
    
    MsgBox "Report generated: " & dict.Count & " categories", vbInformation
    
CleanUp:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub
    
ErrHandler:
    MsgBox "Error: " & Err.Description, vbCritical
    Resume CleanUp
End Sub

Template 2: Batch Process Multiple Sheets

Option Explicit

' ============================================================
' Module: ModBatchProcess
' Purpose: Apply same operation to all data sheets
' ============================================================

Public Sub BatchProcessSheets()
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet
    Dim processedCount As Long
    
    For Each ws In ThisWorkbook.Worksheets
        ' Skip non-data sheets
        If Left(ws.Name, 1) <> "_" And ws.Name <> "Summary" And ws.Name <> "Config" Then
            Call ProcessSingleSheet(ws)
            processedCount = processedCount + 1
        End If
    Next ws
    
    MsgBox processedCount & " sheets processed.", vbInformation
    
CleanUp:
    Application.ScreenUpdating = True
    Exit Sub
    
ErrHandler:
    MsgBox "Error on sheet '" & ws.Name & "': " & Err.Description, vbCritical
    Resume CleanUp
End Sub

Private Sub ProcessSingleSheet(ws As Worksheet)
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Example: Add a "Total" row at the bottom
    Dim lastCol As Long
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    
    Dim totalRow As Long
    totalRow = lastRow + 1
    
    ws.Cells(totalRow, 1).Value = "Total"
    ws.Cells(totalRow, 1).Font.Bold = True
    
    Dim col As Long
    For col = 2 To lastCol
        ' Only sum if column contains numbers
        If IsNumeric(ws.Cells(2, col).Value) Then
            ws.Cells(totalRow, col).Formula = "=SUM(" & _
                ws.Cells(2, col).Address & ":" & ws.Cells(lastRow, col).Address & ")"
            ws.Cells(totalRow, col).Font.Bold = True
        End If
    Next col
End Sub

Template 3: Data Validation & Cleanup

Option Explicit

' ============================================================
' Module: ModDataCleanup
' Purpose: Validate and clean data, log issues
' ============================================================

Public Sub ValidateAndClean()
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    Dim wsData As Worksheet
    Dim wsLog As Worksheet
    Dim lastRow As Long
    Dim logRow As Long
    Dim issueCount As Long
    
    Set wsData = ThisWorkbook.Sheets("Data")
    lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
    
    ' Create log sheet
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets("ValidationLog").Delete
    Application.DisplayAlerts = True
    On Error GoTo ErrHandler
    
    Set wsLog = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsLog.Name = "ValidationLog"
    wsLog.Range("A1:D1").Value = Array("Row", "Column", "Issue", "Original Value")
    logRow = 2
    
    Dim i As Long
    For i = 2 To lastRow
        ' Check: Empty required fields (columns A-C)
        Dim col As Long
        For col = 1 To 3
            If IsEmpty(wsData.Cells(i, col)) Or Trim(CStr(wsData.Cells(i, col).Value)) = "" Then
                wsLog.Cells(logRow, 1).Value = i
                wsLog.Cells(logRow, 2).Value = wsData.Cells(1, col).Value
                wsLog.Cells(logRow, 3).Value = "Empty required field"
                logRow = logRow + 1
                issueCount = issueCount + 1
            End If
        Next col
        
        ' Check: Numeric column D should be positive
        If Not IsEmpty(wsData.Cells(i, 4)) Then
            If Not IsNumeric(wsData.Cells(i, 4).Value) Then
                wsLog.Cells(logRow, 1).Value = i
                wsLog.Cells(logRow, 2).Value = wsData.Cells(1, 4).Value
                wsLog.Cells(logRow, 3).Value = "Non-numeric value"
                wsLog.Cells(logRow, 4).Value = wsData.Cells(i, 4).Value
                logRow = logRow + 1
                issueCount = issueCount + 1
            ElseIf CDbl(wsData.Cells(i, 4).Value) < 0 Then
                wsLog.Cells(logRow, 1).Value = i
                wsLog.Cells(logRow, 2).Value = wsData.Cells(1, 4).Value
                wsLog.Cells(logRow, 3).Value = "Negative value"
                wsLog.Cells(logRow, 4).Value = wsData.Cells(i, 4).Value
                logRow = logRow + 1
                issueCount = issueCount + 1
            End If
        End If
        
        ' Clean: Trim whitespace from text columns
        For col = 1 To 3
            If Not IsEmpty(wsData.Cells(i, col)) Then
                Dim cleaned As String
                cleaned = Trim(CStr(wsData.Cells(i, col).Value))
                If cleaned <> CStr(wsData.Cells(i, col).Value) Then
                    wsData.Cells(i, col).Value = cleaned
                End If
            End If
        Next col
    Next i
    
    ' Format log
    wsLog.Columns("A:D").AutoFit
    wsLog.Range("A1:D1").Font.Bold = True
    
    If issueCount > 0 Then
        wsLog.Activate
        MsgBox issueCount & " issues found. See ValidationLog sheet.", vbExclamation
    Else
        MsgBox "All data validated. No issues found.", vbInformation
    End If
    
CleanUp:
    Application.ScreenUpdating = True
    Exit Sub
    
ErrHandler:
    MsgBox "Error: " & Err.Description, vbCritical
    Resume CleanUp
End Sub

Template 4: Multi-File Consolidation

Option Explicit

' ============================================================
' Module: ModConsolidate
' Purpose: Merge data from multiple Excel files into one sheet
' ============================================================

Public Sub ConsolidateFiles()
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    ' Let user select files
    Dim files As Variant
    files = Application.GetOpenFilename( _
        FileFilter:="Excel Files (*.xlsx;*.xlsm),*.xlsx;*.xlsm", _
        Title:="Select Files to Consolidate", _
        MultiSelect:=True)
    
    If Not IsArray(files) Then
        MsgBox "No files selected.", vbInformation
        GoTo CleanUp
    End If
    
    Dim wsDest As Worksheet
    Set wsDest = ThisWorkbook.Sheets("Consolidated")
    wsDest.Cells.Clear
    
    Dim destRow As Long
    destRow = 1
    Dim headerWritten As Boolean
    
    Dim fileIndex As Long
    For fileIndex = LBound(files) To UBound(files)
        Dim wbSource As Workbook
        Set wbSource = Workbooks.Open(CStr(files(fileIndex)), ReadOnly:=True)
        
        Dim wsSource As Worksheet
        Set wsSource = wbSource.Sheets(1)  ' First sheet
        
        Dim srcLastRow As Long
        srcLastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
        
        Dim srcLastCol As Long
        srcLastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
        
        ' Copy header from first file only
        If Not headerWritten Then
            wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, srcLastCol)).Copy _
                Destination:=wsDest.Cells(destRow, 1)
            ' Add "Source File" column
            wsDest.Cells(destRow, srcLastCol + 1).Value = "Source File"
            destRow = destRow + 1
            headerWritten = True
        End If
        
        ' Copy data rows
        If srcLastRow >= 2 Then
            wsSource.Range(wsSource.Cells(2, 1), wsSource.Cells(srcLastRow, srcLastCol)).Copy _
                Destination:=wsDest.Cells(destRow, 1)
            
            ' Tag source file
            Dim r As Long
            For r = destRow To destRow + srcLastRow - 2
                wsDest.Cells(r, srcLastCol + 1).Value = Dir(CStr(files(fileIndex)))
            Next r
            
            destRow = destRow + srcLastRow - 1
        End If
        
        wbSource.Close SaveChanges:=False
    Next fileIndex
    
    wsDest.Columns.AutoFit
    MsgBox "Consolidated " & UBound(files) - LBound(files) + 1 & " files, " & _
           destRow - 2 & " data rows.", vbInformation
    
CleanUp:
    Application.ScreenUpdating = True
    Exit Sub
    
ErrHandler:
    MsgBox "Error: " & Err.Description, vbCritical
    If Not wbSource Is Nothing Then wbSource.Close SaveChanges:=False
    Resume CleanUp
End Sub

Template 5: Button-Triggered Automation

' ============================================================
' In ThisWorkbook module — create button on sheet
' ============================================================

' Add button programmatically (run once):
Sub CreateRunButton()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Dashboard")
    
    Dim btn As Button
    Set btn = ws.Buttons.Add(Left:=10, Top:=10, Width:=120, Height:=36)
    btn.Caption = "Generate Report"
    btn.OnAction = "ModMonthlyReport.GenerateMonthlyReport"
    btn.Font.Size = 11
End Sub

Template 6: Protected Sheet with Editable Ranges

Option Explicit

' ============================================================
' Module: ModProtection
' Purpose: Lock sheet but allow editing in specific ranges
' ============================================================

Public Sub SetupProtection()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Input")
    
    ' First unlock everything
    ws.Unprotect Password:="admin123"
    ws.Cells.Locked = True
    
    ' Unlock editable ranges
    ws.Range("C5:C20").Locked = False     ' Input cells
    ws.Range("E5:E20").Locked = False     ' Comment cells
    
    ' Visual hint: light yellow for editable cells
    ws.Range("C5:C20").Interior.Color = RGB(255, 255, 230)
    ws.Range("E5:E20").Interior.Color = RGB(255, 255, 230)
    
    ' Protect with options
    ws.Protect Password:="admin123", _
        DrawingObjects:=True, _
        Contents:=True, _
        Scenarios:=True, _
        AllowFormattingCells:=False, _
        AllowInsertingRows:=False, _
        AllowDeletingRows:=False, _
        AllowSorting:=True, _
        AllowFiltering:=True, _
        AllowUsingPivotTables:=False
    
    MsgBox "Sheet protected. Editable ranges highlighted in yellow.", vbInformation
End Sub

13 KiB Executable File Raw Blame History

VBA Code Templates

Template 1: Auto-Generate Monthly Report

Template 2: Batch Process Multiple Sheets

Template 3: Data Validation & Cleanup

Template 4: Multi-File Consolidation

Template 5: Button-Triggered Automation

Template 6: Protected Sheet with Editable Ranges

13 KiB

Executable File

Raw Blame History