performance issue - Rearranging columns based on column header

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

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 2

The below might be of some help, if it is not too much effort.

1. 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)

2. 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 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.