Sub reorderColumnsByRanking() ' FaneDuru inspired code, Keeps formatting, Keeps unlisted columns
' ' Average time for 50k rows = 0.177266 seconds
Dim StartTime As Double
'
Dim lastColumn As Long
Dim LastUsedHeaderColumn As Long, NextFreeHeaderColumn As Long
Dim MaxTimedLoops As Long
Dim TimedLoopCounter As Long
Dim TimerResultColumn As Long
Dim fC As Range
Dim TimerResultColumnLetter As String
Dim TimingsArray() As Variant
'
Dim HeaderMatchFound As Boolean
Dim ColumnNumber As Long
Dim CurrentHeaderDictionary As Object
Dim cel As Range
Dim HeaderNumber As Variant
Dim requiredColumns As Variant
Dim HeaderName_DesiredPosition As Variant
Dim ws As Worksheet
'
Set CurrentHeaderDictionary = CreateObject("scripting.dictionary")
Set ws = ActiveSheet ' <--- Set the name of the sheet that contains the data
'
LastUsedHeaderColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column ' Get LastUsedHeaderColumn
NextFreeHeaderColumn = LastUsedHeaderColumn '
'
requiredColumns = Split("Client|1,Job|2,Job description|3,Job Phase|4,Phase description|5,Job Status|6," & _
"Booked Charge|7,Ticketed Hours|8,Time Actual Charge|9,PO Actual Charge|10,PO Estimate Charge|11," & _
"Exp Actual Charge|12,Exp Estimate Charge|13,Billing Plan - Planned Value (Invoicing)|14," & _
"Billing Plan - Recognise Value|15,Billing Plan - Notional Costs (Disbursements)|16," & _
"Billing Plan - Profit Forecast (Fee Revenue)|17", ",") '
'
LastUsedHeaderColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column ' Get LastUsedHeaderColumn
NextFreeHeaderColumn = LastUsedHeaderColumn '
MaxTimedLoops = 102
'
ReDim TimingsArray(1 To MaxTimedLoops, 1 To 1)
'
For TimedLoopCounter = 1 To MaxTimedLoops
Call RestoreOriginalData
'
StartTime = Timer
'
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'
ws.Range("A1").EntireRow.Insert ' Insert helper row
'
'-------------------------------------------------------------------------------------------------------------------
'
' Append the missing column headers to the end of the current headers
For Each cel In ws.Rows(1).Cells ' Loop through the cells in the header row
If Len(cel) > 0 Then CurrentHeaderDictionary(cel.Value) = True ' If Header name is found then save it to CurrentHeaderDictionary
If cel.End(xlToRight).Column = ws.Columns.Count Then Exit For ' If last column header has been checked then exit this loop
Next ' Loop back
'
For HeaderNumber = LBound(requiredColumns) To UBound(requiredColumns) ' Loop through header names in requiredColumns
If Not CurrentHeaderDictionary(requiredColumns(HeaderNumber)) Then ' If header name being checked is not in the CurrentHeaderDictionary then ...
If ws.Cells(1) = "" Then ' If the first header cell is blank then ...
ws.Cells(1) = requiredColumns(HeaderNumber) ' Save the header name being checked into the first header cell
ElseIf ws.Cells(1).Offset(, 1) = "" Then ' Else If the second header cell is blank then ...
ws.Cells(1).Offset(, 1) = requiredColumns(HeaderNumber) ' Save the header name being checked into the second header cell
Else ' Else ...
ws.Cells(1).End(xlToRight).Offset(, 1) = requiredColumns(HeaderNumber) ' Save the header name being checked into the next blank header cell
End If
End If
Next ' Loop back
'
'-------------------------------------------------------------------------------------------------------------------
'
For ColumnNumber = 1 To LastUsedHeaderColumn
For Each HeaderName_DesiredPosition In requiredColumns
' If IsFound(ws.Cells(2, ColumnNumber), CStr(Split(HeaderName_DesiredPosition, "|")(0))) Then
Set fC = ws.Cells(2, ColumnNumber).Find(CStr(Split(HeaderName_DesiredPosition, "|")(0)))
'
If Not fC Is Nothing Then
ws.Cells(1, ColumnNumber).value2 = Split(HeaderName_DesiredPosition, "|")(1)
HeaderMatchFound = True
Exit For
End If
Next
'
' If Not HeaderMatchFound Then ws.Cells(1, ColumnNumber).Value = 16000
If Not HeaderMatchFound Then
NextFreeHeaderColumn = NextFreeHeaderColumn + 1 ' Increment NextFreeHeaderColumn
ws.Cells(1, ColumnNumber).value2 = NextFreeHeaderColumn ' Save NextFreeHeaderColumn to ws.Cells(1, ColumnNumber)
End If
'
HeaderMatchFound = False
Next
'
ws.Sort.SortFields.Add Key:=ws.Range(ws.Cells(1, 1), ws.Cells(1, LastUsedHeaderColumn)), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal 'Sort LeftToRight
'
With ws.Sort
.SetRange ws.Range(ws.Cells(1, 1), ws.Cells(1, LastUsedHeaderColumn)).EntireColumn
.Header = xlYes
.Orientation = xlLeftToRight
.Apply
End With
'
ws.Rows(1).Delete 'Delete helper row
'
ws.UsedRange.Columns.AutoFit ' Autofit the column widths
'
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
'
TimingsArray(TimedLoopCounter, 1) = Timer - StartTime
'
Debug.Print "Time to complete reorderColumnsByRanking = " & Timer - StartTime & " seconds." ' Display the Timing result to the VBE 'Immediate' window ... CTRL+G in the VBE
Next
'
' Find the last column in the worksheet
lastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
TimerResultColumn = lastColumn + 1
'
TimerResultColumnLetter = Split(Cells(1, TimerResultColumn).Address, "$")(1)
'
' Display the array of times now ***
Range(TimerResultColumnLetter & "2").Resize(UBound(TimingsArray, 1), UBound(TimingsArray, 2)) = TimingsArray
'
Range(TimerResultColumnLetter & MaxTimedLoops + 3) = "Average Time" '
'
Range(TimerResultColumnLetter & MaxTimedLoops + 4).Formula = "=(SUM(" & TimerResultColumnLetter & "2:" & _
TimerResultColumnLetter & MaxTimedLoops + 1 & ")-(SUM(MAX(" & TimerResultColumnLetter & "2:" & _
TimerResultColumnLetter & MaxTimedLoops + 1 & ")+MIN(" & TimerResultColumnLetter & "2:" & _
TimerResultColumnLetter & MaxTimedLoops + 1 & "))))/(COUNT(" & TimerResultColumnLetter & "2:" & _
TimerResultColumnLetter & MaxTimedLoops + 1 & ")-2)" ' Display the average time for all the timings, not counting the highest & lowest value
'
MsgBox "Done." ' Notify the user that all of the loops chosen to perform have completed
End Sub
