Option Explicit
‘ ==========================
‘ Module: Consolidate + Button
‘ ==========================
‘ Main consolidation macro
Public Sub Consolidate_All_Sheets_To_Ordered_Format()
‘ Consolidate all sheets into one, keeping fixed header order (user-specified order)
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet, dest As Worksheet
Dim headerOrder As Variant
Dim extraHeaders As Object
Dim destHeaders() As String
Dim lastRowSrc As Long, lastColSrc As Long
Dim destRow As Long
Dim i As Long, j As Long, c As Long
Dim hdr As String
Dim destName As String
Dim backupName As String
Dim totalCols As Long
‘ — final 13-column order as per your image —
headerOrder = Array(“Service task”, “Project code”, “PO code”, “PR item number”, _
“SO reference”, “Client PO code”, “PO vendor code”, “Item code”, _
“Item service type”, “Item description”, “Status”, _
“PO ERP code”, “PO vendor name”)
Set extraHeaders = CreateObject(“Scripting.Dictionary”)
destName = “Consolidated_PO”
‘ — Backup old consolidated sheet if exists (make unique backup name) —
If SheetExists(wb, destName) Then
backupName = “Backup_” & destName & “_” & Format(Now, “yyyymmdd_hhnnss”)
Dim k As Long: k = 1
Do While SheetExists(wb, backupName)
backupName = “Backup_” & destName & “” & Format(Now, “yyyymmdd_hhnnss”) & “” & k
k = k + 1
Loop
wb.Worksheets(destName).Name = backupName
End If
‘ — Step 1: Collect extra headers from all sheets —
For Each ws In wb.Worksheets
If Left(ws.Name, 7) <> “Backup_” And ws.Name <> destName Then
If Application.WorksheetFunction.CountA(ws.Rows(1)) > 0 Then
lastColSrc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For c = 1 To lastColSrc
hdr = Trim(CStr(ws.Cells(1, c).Value))
If hdr <> “” Then
Dim existsInOrder As Boolean
existsInOrder = False
For i = LBound(headerOrder) To UBound(headerOrder)
If StrComp(headerOrder(i), hdr, vbTextCompare) = 0 Then
existsInOrder = True
Exit For
End If
Next i
If Not existsInOrder Then
If Not extraHeaders.Exists(hdr) Then extraHeaders.Add hdr, hdr
End If
End If
Next c
End If
End If
Next ws
‘ — Step 2: Combine fixed headers + extras —
ReDim destHeaders(0 To UBound(headerOrder))
For i = LBound(headerOrder) To UBound(headerOrder)
destHeaders(i) = headerOrder(i)
Next i
If extraHeaders.Count > 0 Then
ReDim Preserve destHeaders(0 To UBound(headerOrder) + extraHeaders.Count)
For i = 1 To extraHeaders.Count
destHeaders(UBound(headerOrder) + i) = extraHeaders.Items()(i – 1)
Next i
End If
totalCols = UBound(destHeaders) + 1
‘ — Step 3: Create destination sheet and add headers —
Set dest = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
dest.Name = destName
For j = 0 To UBound(destHeaders)
dest.Cells(1, j + 1).Value = destHeaders(j)
Next j
destRow = 2
‘ — Step 4: Copy data from all sheets (array-based for speed) —
For Each ws In wb.Worksheets
If Left(ws.Name, 7) <> “Backup_” And ws.Name <> destName Then
If Application.WorksheetFunction.CountA(ws.Cells) > 0 Then
On Error Resume Next
lastRowSrc = ws.Cells.Find(What:=”*”, LookIn:=xlValues, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
On Error GoTo 0
If lastRowSrc <= 1 Then GoTo NextSheet
lastColSrc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
‘ Map headers to source column numbers
Dim hdrMap As Object: Set hdrMap = CreateObject(“Scripting.Dictionary”)
For c = 1 To lastColSrc
hdr = Trim(CStr(ws.Cells(1, c).Value))
If hdr <> “” Then
If Not hdrMap.Exists(hdr) Then hdrMap.Add hdr, c
End If
Next c
‘ Read source block into array (fast)
Dim srcArr As Variant
srcArr = ws.Range(ws.Cells(2, 1), ws.Cells(lastRowSrc, lastColSrc)).Value
Dim rowsCount As Long
rowsCount = 0
If Not IsEmpty(srcArr) Then
rowsCount = UBound(srcArr, 1)
End If
If rowsCount >= 1 Then
Dim outArr() As Variant
ReDim outArr(1 To rowsCount, 1 To totalCols)
Dim srcColIndex As Long
Dim r As Long ‘ <– declared r here
For r = 1 To rowsCount
For j = 0 To UBound(destHeaders)
hdr = destHeaders(j)
If hdrMap.Exists(hdr) Then
srcColIndex = hdrMap(hdr)
If srcColIndex <= lastColSrc Then
outArr(r, j + 1) = srcArr(r, srcColIndex)
Else
outArr(r, j + 1) = “”
End If
Else
outArr(r, j + 1) = “”
End If
Next j
Next r
‘ Write block to destination in one assignment
dest.Cells(destRow, 1).Resize(rowsCount, totalCols).Value = outArr
destRow = destRow + rowsCount
End If
End If
End If
NextSheet:
Next ws
‘ — Step 5: Formatting the final sheet —
With dest.Rows(1)
.Font.Bold = True
.Font.Color = vbRed
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Interior.Color = RGB(255, 255, 0) ‘ Yellow background
.RowHeight = 25
End With
If destRow > 2 Then
dest.Range(dest.Cells(1, 1), dest.Cells(destRow – 1, totalCols)).AutoFilter
Else
dest.Range(dest.Cells(1, 1), dest.Cells(1, totalCols)).AutoFilter
End If
dest.Columns(“A:” & ColLetter(totalCols)).AutoFit
dest.Activate
dest.Range(“A2”).Select
ActiveWindow.FreezePanes = True
MsgBox “✅ Consolidation complete! ‘” & destName & “‘ created successfully with ” & totalCols & ” columns.”, vbInformation
Cleanup:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Exit Sub
ErrHandler:
MsgBox “Error (” & Err.Number & “): ” & Err.Description, vbExclamation
Resume Cleanup
End Sub
‘ — Create / Replace a clickable shape-button on first worksheet that runs the macro —
Public Sub CreateConsolidateButton()
Dim ws As Worksheet
Dim shp As Shape
Dim btnName As String: btnName = “ConsolidateButton”
Dim wbName As String
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(1) ‘ change index or name if you want specific sheet
If ws Is Nothing Then Exit Sub
‘ Delete previous button if exists
For Each shp In ws.Shapes
If shp.Name = btnName Then
shp.Delete
Exit For
End If
Next shp
On Error GoTo 0
‘ Add a rounded rectangle shape to act as a button
Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, 10, 10, 200, 40)
With shp
.Name = btnName
.TextFrame2.TextRange.Characters.Text = “Run Consolidation”
.TextFrame2.VerticalAnchor = msoAnchorMiddle
.TextFrame2.TextRange.Font.Size = 12
.TextFrame2.TextRange.Font.Bold = msoTrue
.Fill.ForeColor.RGB = RGB(91, 155, 213) ‘ light blue
.Line.Visible = msoFalse
‘ assign the macro using workbook-qualified name to avoid ambiguity
wbName = ThisWorkbook.Name
.OnAction = “‘” & wbName & “‘!Consolidate_All_Sheets_To_Ordered_Format”
End With
End Sub
‘ Optional: remove the button
Public Sub RemoveConsolidateButton()
Dim ws As Worksheet
Dim shp As Shape
Dim btnName As String: btnName = “ConsolidateButton”
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(1)
If ws Is Nothing Then Exit Sub
For Each shp In ws.Shapes
If shp.Name = btnName Then shp.Delete: Exit For
Next shp
On Error GoTo 0
End Sub
‘ — Helper: check if sheet exists —
Private Function SheetExists(wb As Workbook, sName As String) As Boolean
Dim t As Worksheet
On Error Resume Next
Set t = wb.Worksheets(sName)
SheetExists = Not t Is Nothing
On Error GoTo 0
End Function
‘ — Helper: convert column number to letter —
Private Function ColLetter(colNum As Long) As String
Dim n As Long
Dim s As String
Dim rmd As Long
n = colNum
s = “”
Do While n > 0
rmd = (n – 1) Mod 26
s = Chr(65 + rmd) & s
n = Int((n – 1) / 26)
Loop
ColLetter = s
End Function
