Attribute VB_Name = "copy2026"
Option Explicit
Public Sub Copy2026MonthSheetsToCurrentSheet()
Dim destinationSheet As Worksheet
Dim sourceWorkbook As Workbook
Dim sourceSheets() As Worksheet
Dim sheet As Worksheet
Dim sheetCount As Long
Dim sourceIndex As Long
Dim nextRow As Long
Dim lastDataRow As Long
Dim totalRow As Long
Dim totalColumn As Variant
Set destinationSheet = ActiveSheet
Set sourceWorkbook = destinationSheet.Parent
If Is2026MonthSheet(destinationSheet.Name) Then
MsgBox "Select the destination sheet before running this macro. " & _
"A 2026-xx monthly sheet cannot be used as the destination.", vbExclamation
Exit Sub
End If
'Collect valid monthly sheets before changing the destination.
For Each sheet In sourceWorkbook.Worksheets
If Not sheet Is destinationSheet Then
If Is2026MonthSheet(sheet.Name) Then
sheetCount = sheetCount + 1
ReDim Preserve sourceSheets(1 To sheetCount)
Set sourceSheets(sheetCount) = sheet
End If
End If
Next sheet
If sheetCount = 0 Then
MsgBox "No sheets named 2026-01 through 2026-12 were found.", vbExclamation
Exit Sub
End If
SortSheetsByName sourceSheets
Application.ScreenUpdating = False
On Error GoTo CopyFailed
'The user requested that all present destination records be overwritten.
destinationSheet.Cells.Clear
'Copy one header and the source column widths.
sourceSheets(1).Range("A1:U1").Copy Destination:=destinationSheet.Range("A1")
sourceSheets(1).Columns("A:U").Copy
destinationSheet.Columns("A:U").PasteSpecial Paste:=xlPasteColumnWidths
Application.CutCopyMode = False
nextRow = 2
For sourceIndex = 1 To sheetCount
With sourceSheets(sourceIndex)
'Column A contains dates; this excludes each sheet's totals row.
lastDataRow = .Cells(.Rows.Count, 1).End(xlUp).Row
If lastDataRow >= 2 Then
.Range(.Cells(2, 1), .Cells(lastDataRow, 21)).Copy _
Destination:=destinationSheet.Cells(nextRow, 1)
nextRow = nextRow + lastDataRow - 1
End If
End With
Next sourceIndex
'Create one totals row for the combined records.
If nextRow > 2 Then
totalRow = nextRow
For Each totalColumn In Array(5, 6, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21)
destinationSheet.Cells(totalRow, CLng(totalColumn)).Formula = _
"=SUM(" & destinationSheet.Cells(2, CLng(totalColumn)).Address(False, False) & _
":" & destinationSheet.Cells(totalRow - 1, CLng(totalColumn)).Address(False, False) & ")"
destinationSheet.Cells(totalRow, CLng(totalColumn)).Font.Bold = True
Next totalColumn
End If
Application.ScreenUpdating = True
destinationSheet.Activate
MsgBox sheetCount & " monthly sheet(s) copied. " & _
(nextRow - 2) & " transaction row(s) imported.", vbInformation
Exit Sub
CopyFailed:
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "The copy failed: " & Err.Description, vbCritical
End Sub
Private Function Is2026MonthSheet(ByVal sheetName As String) As Boolean
Dim monthNumber As Long
If Not sheetName Like "2026-##" Then Exit Function
monthNumber = CLng(Right$(sheetName, 2))
Is2026MonthSheet = (monthNumber >= 1 And monthNumber <= 12)
End Function
Private Sub SortSheetsByName(ByRef sheets() As Worksheet)
Dim firstIndex As Long
Dim secondIndex As Long
Dim temporarySheet As Worksheet
For firstIndex = LBound(sheets) To UBound(sheets) - 1
For secondIndex = firstIndex + 1 To UBound(sheets)
If sheets(secondIndex).Name < sheets(firstIndex).Name Then
Set temporarySheet = sheets(firstIndex)
Set sheets(firstIndex) = sheets(secondIndex)
Set sheets(secondIndex) = temporarySheet
End If
Next secondIndex
Next firstIndex
End Sub