Excel Top Header Manage VBA Code

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 Required Column Order — headerOrder = Array( _ “Service task”, _ “Phase”, _ “Project code”, _ “ST element code”, _ “Completion status”, _ “PO code”, _ “PR item number”, _ “SO reference”, _ “Client PO code”, _ “Item code”, _ “Item description”, _ “Status”, _ “PO ERP code”, _ “PO vendor name”, _ “Client acceptance status”, _ “WCC code”, _ “WCC status” _ ) 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