File Size Is Causing Column Reordering VBA Macro to Fail

[antman2988]

Hello! I'm using the below code to reorder my worksheet's columns based on a predetermined column order. This code works as long as there are less than 500k rows, but once the number of rows exceeds 500k, I receive an application-defined or object-defined error. Is this code limited by memory? If so, is there a better way to write this code? I saw this post and was wondering if it would be a better solution. Also, in my code, I create a table object and was wondering if I should reorder the ListColumns instead. By the time the table object has been created, there are quite a few less columns, which would probably help with the memory issues. What's a good way to reorder ListColumns? Is it possible? I wasn't able to find much on it so far.

'This macro will reorder the column numbers by declaring the new order in an array
'It will then use the Evaluate and Index functions to place the range's existing column order in the new order
Sub RearrangeColumns()
  Dim newColumnOrder As Variant
  
  'newColumnOrder = Array(1, 2, 3, 4, 41, 42, 43, 44, 5, 6, 49, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 45, 46, 47, 48, 50, 51, 52)
  newColumnOrder = Array(1, 2, 3, 4, 78, 79, 80, 81, 5, 6, 86, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, _
        40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 82, 83, 84, 85, 87, 88, 89, 90)
  
  Range("A1").Resize(Cells.Find("*", , xlFormulas, , xlRows, xlPrevious).Row, UBound(newColumnOrder) + 1) = Application.Index(Cells, Evaluate("ROW(1:" & Cells.Find("*", , xlFormulas, , xlRows, xlPrevious).Row & ")"), newColumnOrder)
End Sub

The commented array code is what I used to rearrange the columns after the table object was created, but it kept destroying the table so I decided to rearrange the columns before creating the table, but now I'm running into issues with larger files. Also, what would the one line code look like if it were to be broken out?

Any help is appreciated. Thanks!

 

[Alex Blakenburg]

I don't know much about this but have you tried turning of some or all of these:-

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

Application.EnableEvents = False

 

[RoryA]

Have you tried adding numbers above your data then using the built in left to right sort?

 

[antman2988]

H

Have you tried adding numbers above your data then using the built in left to right sort

Hi Rory! That's the solution I see most often and is similar to the post I had linked. Is it the most optimal solution for reordering columns? I should probably just trash what I'm currently using and try something else. It takes a long time to process it, and I'm thinking the memory overload is due to the Application.Index since I know it processes quite slowly. Also, is there a way to reorder ListColumns? I tried testing a couple of methods but had no luck.

 

[RoryA]

For large data sets, I'd stay away from tables personally. I find they don't work that well.

Your current code is creating a very large array in memory, so I'd try the sort and see if that works better.

 

[antman2988]

This is the solution I was able to get working on a large data set. It's doesn't take too long to process although I'm sure it can be improved.

Sub ReorderColumns()
    Const newColumnOrder As String = "A, B, C, D, BZ, CA, CB, CC, E, F, CH, G, H, I, J, K, L, M, N, O, P, Q, R, S, T, U, V, W, X, Y, Z, AA, AB, AC, AD, AE, AF, AG, AH, AI, AJ, AK, AL, AM, AN, AO, AP, AQ, AR, AS, AT, AU, AV, AW, AX, AY, AZ, BA, BB, BC, BD, BE, BF, BG, BH, BI, BJ, BK, BL, BM, BN, BO, BP, BQ, BR, BS, BT, BU, BV, BW, BX, BY, CD, CE, CF, CG, CI, CJ, CK, CL"

    Dim dict As Object
    Dim rng As Range
    Dim c As Integer
    Dim v, k
    Dim lastRow As Long
    Dim lastCol As Long
    Dim colRng As Range

    Set dict = CreateObject("Scripting.Dictionary")
    lastRow = Cells.Find("*", , xlFormulas, , xlRows, xlPrevious, , , False).row
    lastCol = Cells.Find("*", , xlFormulas, , xlColumns, xlPrevious, , , False).Column
    Set rng = Range("A1", Cells(lastRow, lastCol))
    If rng Is Nothing Then Exit Sub

    If Not rng.Columns.Count - 1 = UBound(Split(newColumnOrder, ", ")) Then
        MsgBox "Split failed.", vbCritical
    End If
    
    For Each v In Split(newColumnOrder, ", ")
        v = Trim(v)
        Set colRng = Range(Columns(v).Address).Resize(rng.Rows.Count)
        dict(colRng.Address) = colRng.Value
    Next

    For Each k In dict.Keys()
        c = c + 1
        rng.Columns(c).Value = dict(k)
    Next

    Set dict = Nothing
End Sub