Reordering Multiple Columns in Excel VBA

excel, vba

Solution

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

Problem

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?

Original source