CODEWITHSUNDEEP
excelvba
114
114

Reputation: 926

Reordering Multiple Columns in Excel VBA

Is there a way to create a 'permutation' macro where you input a set of columns (A....Z) and it gives a chosen alternate ordering (e.g. (B,A,E,D,C,...,Z))? I imagine this is something that has been done before but it is surprisingly hard to find any precedent.

Initially I was thinking of copying / pasting using Range().Copy / .Paste in a tedious way or similarly with Columns, that is:

Columns("C:C").Insert Shift:=xlToRight
Columns("D:D").Cut
Columns("A:A").Insert Shift:=xlToRight
Columns("G:G").Cut
Columns("E:E").Insert Shift:=xlToRight
...

UPDATE:

I did find the following code here:

Sub REORDER()

Dim arrColOrder As Variant, ndx As Integer
Dim Found As Range, counter As Integer

'Place the column headers in the end result order you want.
arrColOrder = Array("COLUMN 2", "COLUMN 4", "COLUMN 6", "COLUMN 10", "COLUMN 1", _
                    "COLUMN 9", "COLUMN 3", "COLUMN 8", "COLUMN 7", "COLUMN 5")

counter = 1

Application.ScreenUpdating = False

For ndx = LBound(arrColOrder) To UBound(arrColOrder)

    Set Found = Rows("1:1").Find(arrColOrder(ndx), LookIn:=xlValues, LookAt:=xlWhole, _
                      SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

    If Not Found Is Nothing Then
        If Found.Column <> counter Then
            Found.EntireColumn.Cut
            Columns(counter).Insert Shift:=xlToRight
            Application.CutCopyMode = False
        End If
        counter = counter + 1
    End If

Next ndx

Application.ScreenUpdating = True

End Sub

What is the process for calling this code in a larger macro?

Upvotes: 5

Views: 29475

Answers (2)

Sermarq
Sermarq

Reputation: 1

I've found this answer in https://code.adonline.id.au/rearrange-columns-excel-vba/ that I found adequate:

Sub Reorder_Columns()
Dim ColumnOrder As Variant, ndx As Integer
Dim Found As Range, counter As Integer
    ColumnOrder = Array("Header 6", "Header 2", "Header 1", "Header 4", "Header 5", "Header 3")  
counter = 1
Application.ScreenUpdating = False
For ndx = LBound(ColumnOrder) To UBound(ColumnOrder) 
    Set Found = Rows("1:1").Find(ColumnOrder(ndx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
    If Not Found Is Nothing Then
        If Found.Column <> counter Then
            Found.EntireColumn.Cut
            Columns(counter).Insert Shift:=xlToRight
            Application.CutCopyMode = False
        End If
    counter = counter + 1
    End If
Next ndx
Application.ScreenUpdating = True
End Sub

Same code with my edit to avoid array/variant:

For ndx = 1 To 6 'maximal index of header
    Set Found = Rows("1:1").Find(Split(ColumnOrder, ",")(ndx - 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
    If Not Found Is Nothing Then
        If Found.Column <> ndx Then
            Found.EntireColumn.Cut
            Columns(ndx).Insert Shift:=xlToRight
            Application.CutCopyMode = False
        End If
    End If
Next ndx

Upvotes: 0

David Zemens
David Zemens

Reputation: 53663

Something like this should get you started. It will need some revision that I don't have time for, if you intend to use it on tables that do not begin in Row 1.

Sub Reorder()
Dim dict As Object
Dim rng As Range, c As Integer

Dim colRng As Range

Set dict = CreateObject("Scripting.Dictionary")
Set rng = Application.InputBox("Select table range", "Select Table", Type:=8)
If rng Is Nothing Then Exit Sub

'you should input a comma-delimited list of column letters, e.g., "E,B,C,A,D"
newOrder = Application.InputBox("Specify new order", "New order")

If Not rng.Columns.Count - 1 = UBound(Split(newOrder, ",")) Then
    MsgBox "Invalid selection", vbCritical
End If


For Each v In Split(newOrder, ",")
    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

Upvotes: 3

Related Questions