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?

Do it using an `Object[][]` all in memory. https://stackoverflow.com/a/2294087/495455 — Jeremy Thompson, Jun 23 '20 at 05:34
I should've mentioned (I will edit my post) that it is of vital importance to keep the formatting of each cell in those columns, because the values are colored and font is different. — smartini, Jun 23 '20 at 05:36
That is a MAJOR point, that means you can't use raw memory with basic types you have to use the Object Model... unless you are really prepared to collect info about each cells style, I do the opposite here https://stackoverflow.com/a/39314154/495455 - it might be cheaper solution (< 5hrs work) to throw hardware at it and run it on an SSD higher CPU. — Jeremy Thompson, Jun 23 '20 at 05:38
thanks, but I am not able to understand how I should use your code, since it is not written in VBA. — smartini, Jun 23 '20 at 05:45
That's my point, if you want to do this fast you should avoid the object model. If you need cell styles then you have to be creative to get the data with styling info. That's the only way to transform this data faster - using a 2D Object array of values and another 2D object array of styles, then you can just `ReDim Preserve` and swap columns in memory (instantly) and then render the data back to the spreadsheet. — Jeremy Thompson, Jun 23 '20 at 05:48
interesting point, I will do some research on how to store the formatting information into a second array - if that solutio exist — smartini, Jun 23 '20 at 05:50
@smartini, As an off-VBA solution, if you have the sorted column headers on a separate sheet, you can create a temp row above the header row and use the `MATCH` formula to get order numbers above each column header. Then you can sort left-to-right on this temp numbered row to get your columns rearranged with formatting intact. — Karthick Ganesan, Jun 23 '20 at 06:28
If you could tell us why you need to rearrange columns there may be a solution you haven't yet considered. — freeflow, Jun 23 '20 at 07:16
@KarthickGanesan I have the sorted columns ready on a temp sheet. Actually I could also put those sorted colum above the header row in the main sheet (numbers from 1 to n), but the real headers are duplicates, as you could tell from my code. I could not solve your idea with the MATCH function though. — smartini, Jun 23 '20 at 08:34
@freeflow I need the rearrangement because out of those hundred columns a couple are very important and need to be at the front of the matrix, the next important one to the right and so on. — smartini, Jun 23 '20 at 08:35
@smartini That's a because not a why. What operation are you doing that requires the reorganisation of columns. — freeflow, Jun 23 '20 at 12:10

Karthick Ganesan · Answer 1 · 2020-06-23T10:30:19.387

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.

wow, that is an excellent solution! It worked with my sample matrix and I will try to implement the specific sort function into VBA so I can fire it when desired. — smartini, Jun 23 '20 at 10:52
That's great! This was the solution I hinted at in the question comments... Cheers :) — Karthick Ganesan, Jun 23 '20 at 11:20

score 1 · Answer 2 · answered Jun 23 '20 at 08:22

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

thank you! your code ist exactly 50% faster than my approach now. maybe it's even exponentially faster if I have more columns in my workbook. — smartini, Jun 23 '20 at 08:50

score 1 · Accepted Answer · answered Jun 23 '20 at 12:26

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

thanks for your contribution. I tried that approach and it's indeed the fastest solution - what a mindblowing performance! thank you all. — smartini, Jun 23 '20 at 14:16
many users of the tool encountered issues after working with it. It took me plenty of hours to pin it down to the root cuase. it is of vital importance to add the following code after the sorting is done! "sh.Sort.SortFields.Clear" without that the file will get corrupted and when starting the workbook again the user will be prompted with repairing options. More details can be found in this thread, where I found the solution to the problem by user @Yoni: https://stackoverflow.com/questions/42999112/excel-corruption-with-vba-sorting-records — smartini, Aug 28 '20 at 16:22
@smartini: You should say something about the issue... I knew about this workaround in case of some installations. I tested the above code, of course, and nothing wrong happened with the workbook, on my installation. I thought you also have a stable version. What Office version do you use? — FaneDuru, Aug 28 '20 at 16:57

score 0 · Answer 4 · answered Jun 23 '20 at 06:29

0

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.

answered Jun 23 '20 at 06:29

FlameHorizon

199
10

Setting the values directly from Range1 to Range2 without copying would be even quicker. No Cut/Copy/Paste. I reckon OP is looking for something super fast like this, you grab the data in a 2D array and swap columns or in this case Transposed Rows: https://stackoverflow.com/a/31976946/495455 – Jeremy Thompson Jun 23 '20 at 06:40
I don't know why, but it took exactly 3x longer than just copying. Maybe it has something to do with my UDFs I have in that worksheet? Actually they should not be fired, because I prevent that in my code at the beginning. – smartini Jun 23 '20 at 08:56

performance issue - Rearranging columns based on column header

4 Answers4