Option Explicit ‘ ========================================= ‘ DPR CONSOLIDATION MACRO ‘ HEADER ROW = 2 ‘ DATA START ROW = 3 ‘ ========================================= Public Sub Consolidate_DPR_Report() On Error GoTo ErrHandler Application.ScreenUpdating = False Application.EnableEvents = False Application.DisplayAlerts = False Dim wb As Workbook Dim ws As Worksheet Dim dest As Worksheet Dim headerOrder As Variant Dim extraHeaders As Object Dim destHeaders() As String Dim lastRowSrc As Long Dim lastColSrc As Long Dim destRow As Long Dim totalCols As Long Dim i As Long Dim j As Long Dim c As Long Dim r As Long Dim hdr As String Dim destName As String Dim backupName As String Set wb = ThisWorkbook ‘ ========================================= ‘ REQUIRED COLUMN ORDER ‘ ========================================= headerOrder = Array( _ “Circle”, _ “PLAN ID”, _ “HOP TYPE”, _ “HOP A-B”, _ “HOP B-A”, _ “SITE A ANT DIA”, _ “SITE B ANT DIA”, _ “SOFT AT OFFER DATE”, _ “SOFT AT ACCEPTANCE DATE”, _ “SOFT-AT STATUS”, _ “PHY-AT OFFER DATE”, _ “PHY-AT ACCEPTANCE DATE”, _ “PHY-AT STATUS”, _ “BOTH AT STATUS” _ ) destName = “Consolidated_DPR” Set extraHeaders = CreateObject(“Scripting.Dictionary”) ‘ ========================================= ‘ BACKUP OLD SHEET ‘ ========================================= If SheetExists(wb, destName) Then backupName = “Backup_” & destName & “_” & _ Format(Now, “yyyymmdd_hhnnss”) wb.Worksheets(destName).Name = backupName End If ‘ ========================================= ‘ COLLECT EXTRA HEADERS ‘ HEADER ROW = 2 ‘ ========================================= For Each ws In wb.Worksheets If Left(ws.Name, 7) <> “Backup_” _ And ws.Name <> destName Then If ws.Visible = xlSheetVisible Then If Application.WorksheetFunction.CountA(ws.Rows(2)) > 0 Then lastColSrc = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column For c = 1 To lastColSrc hdr = Trim(CStr(ws.Cells(2, 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 End If Next c End If End If End If Next ws ‘ ========================================= ‘ FINAL HEADER ARRAY ‘ ========================================= 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 ‘ ========================================= ‘ CREATE DESTINATION SHEET ‘ ========================================= Set dest = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count)) dest.Name = destName ‘ ========================================= ‘ WRITE HEADERS ‘ ========================================= For j = 0 To UBound(destHeaders) dest.Cells(1, j + 1).Value = destHeaders(j) Next j destRow = 2 ‘ ========================================= ‘ COPY DATA ‘ ========================================= For Each ws In wb.Worksheets If Left(ws.Name, 7) <> “Backup_” _ And ws.Name <> destName Then If ws.Visible = xlSheetVisible 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 <= 2 Then GoTo NextSheet lastColSrc = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column ' ========================================= ' HEADER MAP ' ========================================= Dim hdrMap As Object Set hdrMap = CreateObject("Scripting.Dictionary") For c = 1 To lastColSrc hdr = Trim(CStr(ws.Cells(2, c).Value)) If hdr <> “” Then If Not hdrMap.Exists(hdr) Then hdrMap.Add hdr, c End If End If Next c ‘ ========================================= ‘ READ DATA ARRAY ‘ DATA START ROW = 3 ‘ ========================================= Dim srcArr As Variant srcArr = ws.Range( _ ws.Cells(3, 1), _ ws.Cells(lastRowSrc, lastColSrc) _ ).Value Dim rowsCount As Long rowsCount = UBound(srcArr, 1) ‘ ========================================= ‘ OUTPUT ARRAY ‘ ========================================= Dim outArr() As Variant ReDim outArr(1 To rowsCount, 1 To totalCols) Dim srcColIndex As Long For r = 1 To rowsCount For j = 0 To UBound(destHeaders) hdr = destHeaders(j) If hdrMap.Exists(hdr) Then srcColIndex = hdrMap(hdr) outArr(r, j + 1) = srcArr(r, srcColIndex) Else outArr(r, j + 1) = “” End If Next j Next r ‘ ========================================= ‘ WRITE TO DESTINATION ‘ ========================================= dest.Cells(destRow, 1).Resize(rowsCount, totalCols).Value = outArr destRow = destRow + rowsCount End If End If End If NextSheet: Next ws ‘ ========================================= ‘ FORMATTING ‘ ========================================= With dest.Rows(1) .Font.Bold = True .Font.Color = vbWhite .Interior.Color = RGB(0, 112, 192) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .WrapText = True .RowHeight = 28 End With ‘ FILTER dest.Range(dest.Cells(1, 1), _ dest.Cells(destRow – 1, totalCols)).AutoFilter ‘ AUTOFIT dest.Cells.EntireColumn.AutoFit ‘ FREEZE TOP ROW dest.Activate ActiveWindow.SplitRow = 1 ActiveWindow.FreezePanes = True MsgBox “✅ DPR Consolidation Completed!” & vbCrLf & _ “Total Rows : ” & destRow – 2, vbInformation Cleanup: Application.ScreenUpdating = True Application.EnableEvents = True Application.DisplayAlerts = True Exit Sub ErrHandler: MsgBox “Error : ” & Err.Description, vbExclamation Resume Cleanup End Sub ‘ ========================================= ‘ CREATE BUTTON ‘ ========================================= Public Sub Create_DPR_Button() Dim ws As Worksheet Dim shp As Shape Dim btnName As String btnName = “Run_DPR_Consolidation” Set ws = ThisWorkbook.Worksheets(1) On Error Resume Next ws.Shapes(btnName).Delete On Error GoTo 0 Set shp = ws.Shapes.AddShape( _ msoShapeRoundedRectangle, _ 10, 10, 220, 40) With shp .Name = btnName .TextFrame2.TextRange.Characters.Text = _ “Run DPR Consolidation” .TextFrame2.TextRange.Font.Size = 12 .TextFrame2.TextRange.Font.Bold = msoTrue .Fill.ForeColor.RGB = RGB(91, 155, 213) .Line.Visible = msoFalse .OnAction = “‘” & ThisWorkbook.Name & _ “‘!Consolidate_DPR_Report” End With MsgBox “✅ Button Created Successfully!”, vbInformation End Sub ‘ ========================================= ‘ SHEET EXISTS CHECK ‘ ========================================= 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