performance issue - Rearranging columns based on column header - excel

Question

I have an Excel Workbook with hundreds of columns to be rearranged. Having tried different approaches to rearrange those columns I have developed my own solution, because it's faster than what I have found here and elsewhere:
How to rearrange the excel columns by the columns header name
https://code.adonline.id.au/rearrange-columns-excel-vba/
My code:
What I basically do is searching the header row for a certain string and copy that column to a temp/helper sheet, when done I search for the next term and so on until all categories are searched. Afterwards I copy the chunk back to the main sheet in the correct order.
edit: it is of vital importance to keep the formatting of each column, so putting everything in an array does not work, because the formatting information will be gone.
Sub cutColumnsToTempAndMoveBackSorted()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Call declareVariables
iCountCompanies = lngLastCol - iColStart + 1
' Timer
Dim StartTime As Double
Dim SecondsElapsed As Double
' Remember time when macro starts
StartTime = Timer
iStartColTemp = 0
wsTempCompanies.UsedRange.Delete
' First copy all columns with "ABC"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "ABC" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "DDD"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "DDD" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "CCC"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "CCC" Or ws.Cells(iRowCategory, i) = "" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "EEE"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "EEE" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
Dim iLastColTemp As Integer: iLastColTemp = iStartColTemp
iStartColTemp = 1
ws.Range(Col_Letter(iColStart) & ":" & Col_Letter(lngLastCol)).Delete 'Col_Letter function gives back the column ist characters instead of column ID
' Move back to Main Sheet
wsTempCompanies.Range(Col_Letter(iStartColTemp) & ":" & Col_Letter(iLastColTemp)).Copy
ws.Range(Col_Letter(iColStart + 1) & ":" & Col_Letter(lngLastCol + 1)).Insert
ws.Columns(iColStart).Delete
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
Debug.Print "Time: " & SecondsElapsed & " Sekunden."
ende:
Application.ScreenUpdating = True
Call activateApplication ' All kinds of screenupdates, such as enableevents, calculations, ...
End Sub
I am still not happy with my solution as it takes just too much time when there are more than 50 columns. Sometimes I have over 300.
Any suggestion to boost the performance?

Answer 1

The below might be of some help, if it is not too much effort.
Sample Dataset in one sheet (let's call this the Main sheet) with,
(Row 2) Sample Header row (includes the lookup keywords - ABC, DDD, CCC, EEE)
(Row 1) A Temp Row (formulated to show Header Order numbers)
References sheet which lists the lookup keywords in required left-to-right sort order
Back in the Main sheet, we'd like to generate the sequence numbers in Row 1.
As highlighted in the 1st image, it can be done with the below MATCH formula in the cell A1,
=MATCH(TRUE,ISNUMBER(SEARCH(References!$A$2:$A$5,A2)),0)
This is required as an array formula and hence should be executed by hitting Ctrl+Shift+Enter
Now copy the cell A1 across columns (in Row 1) through the last column
Row 1 will now contain sequence numbers 1..n, where n is the numbers of rows found in the References sheet. It may also contain #N/A error value returned by the MATCH formula if no match is found from the 'References' sheet
Now, apply sort (Sort Option: Left to Right) and Sort By Row 1.
The columns should now be sorted as per requirement and with formatting intact.
Result (Sorted)
Please note that a column header not matching any keywords has been moved to the end.
Once you find everything in place, now you can go ahead and delete the (Row 1) temp row in the Main sheet
P.S: While I haven't computed the performance of this approach on a large dataset, I'm sure it will be fairly quick.

Answer 2

Please test the next code, please. Most of the credit must go to #Karthick Ganesan for his idea. The code only puts his idea in VBA:
Sub reorderColumnsByRanking()
Dim sh As Worksheet, arrOrd As Variant, lastCol As Long, i As Long
Dim El As Variant, boolFound As Boolean, isF As Long
Set sh = ActiveSheet 'use here your necessary sheet
lastCol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
arrOrd = Split("ABC|1,DDD|2,CCC|3,EEE|4", ",") 'load criteria and their rank
'insert a helping row____________________
sh.Range("A1").EntireRow.Insert xlAbove
'________________________________________
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Rank the columns_______________________________________________________________
For i = 1 To lastCol
For Each El In arrOrd
If IsFound(sh.Cells(2, i), CStr(Split(El, "|")(0))) Then
sh.Cells(1, i).Value = Split(El, "|")(1): boolFound = True: Exit For
End If
Next
If Not boolFound Then sh.Cells(1, i).Value = 16000
boolFound = False
Next i
'_______________________________________________________________________________
'Sort LeftToRight_____________________________________________________________
sh.Sort.SortFields.Add2 key:=sh.Range(sh.Cells(1, 1), sh.Cells(1, lastCol)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With sh.Sort
.SetRange sh.Range(sh.Cells(1, 1), sh.Cells(1, lastCol)).EntireColumn
.Header = xlYes
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
'____________________________________________________________________________
'Delete helping first row____
sh.Rows(1).Delete xlDown
'____________________________
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
End Sub
Private Function IsFound(rng As Range, strS As String) As Boolean
Dim fC As Range
Set fC = rng.Find(strS)
If Not fC Is Nothing Then
IsFound = True
Else
IsFound = False
End If
End Function

Answer 3

Here's my take on the solution. It's pretty similar to the one in your first link by #BruceWayne except this will go straight to the correct column rather than checking each one.
At the moment the code looks for partial matches - so "ABCDEF" would be found for both "ABC" and "DEF". Change xlPart to xlWhole in the FIND command to have it match against exact headings.
Sub Test()
Dim CorrectOrder() As Variant
Dim OrderItem As Variant
Dim FoundItem As Range
Dim FirstAddress As String
Dim NewOrder As Collection
Dim LastColumn As Range
Dim NewPosition As Long
Dim tmpsht As Worksheet
CorrectOrder = Array("ABC", "DEF", "GHI", "JKL")
With ThisWorkbook.Worksheets("Sheet1")
Set LastColumn = .Cells(2, .Columns.Count).End(xlToLeft) 'Return a reference to last column on row 2.
Set NewOrder = New Collection
With .Range(.Cells(2, 1), LastColumn) 'Refer to the range A2:LastColumn.
'Search for each occurrence of each value and add the column number to a collection in the order found.
For Each OrderItem In CorrectOrder
Set FoundItem = .Find(What:=OrderItem, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart)
If Not FoundItem Is Nothing Then
FirstAddress = FoundItem.Address
Do
NewOrder.Add FoundItem.Column
Set FoundItem = .FindNext(FoundItem)
Loop While FoundItem.Address <> FirstAddress
End If
Next OrderItem
End With
End With
'Providing some columns have been found then move them in order to a temporary sheet.
If NewOrder.Count > 1 Then
NewPosition = 2
Set tmpsht = ThisWorkbook.Worksheets.Add
For Each OrderItem In NewOrder
ThisWorkbook.Worksheets("Sheet1").Columns(OrderItem).Cut _
tmpsht.Columns(NewPosition)
NewPosition = NewPosition + 1
Next OrderItem
'Copy the reordered columns back to the original sheet.
tmpsht.Columns(2).Resize(, NewOrder.Count).Cut _
ThisWorkbook.Worksheets("Sheet1").Columns(2)
'Delete the temp sheet.
Application.DisplayAlerts = False
tmpsht.Delete
Application.DisplayAlerts = True
End If
End Sub

Answer 4

You can use Cut which is significantly faster (on PC it is around 20-30 times faster than Copy/Insert approach. Cut also preserves formatting.
Here, is an example how it can be implemented into your code:
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "EEE" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Cut wsTempCompanies.Columns(iStartColTemp)
End If
Next i
If for some reason, you are not allowed to cut elements from ws, then it is probably good idea to create temporary copy of that working to work on.