Moving Columns based on header name

Question

I have a macro that rearranges the columns into a particular order.

Sub ArrangeColumns()

' ArrangeColumns Macro

    Columns("C:C").Select
    Application.CutCopyMode = False
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("K:K").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Columns("H:H").Select
    Selection.Cut
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight
    Columns("J:J").Select
    Selection.Cut
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight
    Columns("J:J").Select
    Selection.Cut
    Columns("I:I").Select
    Selection.Insert Shift:=xlToRight
    Columns("K:K").Select
    Selection.Cut
    Columns("J:J").Select
    Selection.Insert Shift:=xlToRight
    Range("P11").Select
End Sub

This no longer works because the columns of the raw data can no longer be guaranteed to be in a specific order.

Is there a way that I can rewrite the above code (Yes it was created by "Record Macro") to replace the lines "Columns("C:C")", Columns("A:A")", etc. with their column header names?

Even better is there a better approach to this problem?

Answer 1

If you know all the header names, you can define an array of the header names and use the array's index to move the columns around.

Sub columnOrder()
Dim search As Range
Dim cnt As Integer
Dim colOrdr As Variant
Dim indx As Integer

colOrdr = Array("id", "last_name", "first_name", "gender", "email", "ip_address") 'define column order with header names here

cnt = 1


For indx = LBound(colOrdr) To UBound(colOrdr)
    Set search = Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
    If Not search Is Nothing Then
        If search.Column <> cnt Then
            search.EntireColumn.Cut
            Columns(cnt).Insert Shift:=xlToRight
            Application.CutCopyMode = False
        End If
    cnt = cnt + 1
    End If
Next indx
End Sub

Any column not named in the array will appear on the right of the ones named.

Answer 2

Alternative using Application.Index in a one liner

For the sake of the art and just to demonstrate a working alternative using the advanced restructuring possibilities of the Application.Index function (c.f. section [2]):

Sub colOrder()
' Purpose: restructure range columns
  With Sheet1                                               ' worksheet referenced e.g. via CodeName
  
    ' [0] identify range
      Dim rng As Range, lastRow&, lastCol&
      lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row        ' get last row and last column
      lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
      Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
      
    ' ~~~~~~~~~~~~
    ' [1] get data
    ' ~~~~~~~~~~~~
      Dim v: v = rng                                        ' assign to 1-based 2-dim datafield array
      
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' [2] restructure column order in array in a one liner
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      v = Application.Index(v, Evaluate("row(1:" & lastRow & ")"), getColNums(v))
      
    ' [3] write data back to sheet
      rng = vbNullString                                    ' clear orginal data
      .Range("A1").Resize(UBound(v), UBound(v, 2)) = v      ' write new data
  
  End With
  
End Sub

Helper function called by above main procedure

The helper function simply returns an array with the correct column numbers found in the current titles; it uses Application.Match to find occurrencies:

Function getColNums(arr) As Variant()
' Purpose: return array of found column number order, e.g. Array(3,2,1,4,6,5)
Dim colOrdr(), titles                                           ' wanted order, current titles
colOrdr = Array("id", "last_name", "first_name", "gender", "email", "ip_address") 'define column order with header names here
titles = Application.Transpose(Application.Transpose(Application.Index(arr, 1, 0)))

Dim i&, ii&, pos                                                ' array counters, element position
ReDim tmp(0 To UBound(colOrdr))                                 ' temporary array to collect found positions
For i = 0 To UBound(colOrdr)                                    ' loop through titles in wanted order
    pos = Application.Match(colOrdr(i), titles, 0)              ' check positions
    If Not IsError(pos) Then tmp(ii) = pos: ii = ii + 1         ' remember found positions, increment counter
Next i
ReDim Preserve tmp(0 To ii - 1)                                 ' remove empty elements
getColNums = tmp                                                ' return array with current column numbers (1-based)
End Function

Related link

I listed some pecularities of the Application.Index function at Insert first column in datafield array without loops or API calls

//Edit due to comment(s) as of 09/25 2021

The modified help function getColNums() includes now an option via a 2nd argument DeleteOtherCols:={False|True} to

• preserve non-listed columns ~~> getColNums(v, DeleteOtherCols:=False) or simply getColNums(v, False); without setting the 3rd argument to True these other columns will be shown right to the listed columns (see remarks to the 3rd argument)
• rearrange only listed columns (i.e. other columns get deleted by default) ~~> getColNums(v) or getColNums(v, True)

as well as an option via a 3rd argument StartWithOtherCols:={False|True}

• to start with not listed columns ~~> getColNums(v, False, StartWithOtherCols:=True) or simply getColNums(v, False, True)
• to continue with not listed columns on the right of the ones named ~~> getColNums(v,False) or getColNums(v,False,False) or or getColNums(v,False,StartWithOtherCols:=False)``:

Function getColNums(arr, _
    Optional DeleteOtherCols As Boolean = True, _
    Optional StartWithOtherCols As Boolean = False) As Variant()
' Purpose: return array of found column number order, e.g. Array(3,2,1,4,6,5)
    Dim colOrdr(), titles                        ' wanted order, current titles
    colOrdr = Array("id", "last_name", "first_name", "gender", "email", "ip_address") 'define column order with header names here
    titles = Application.Transpose(Application.Transpose(Application.Index(arr, 1, 0)))

    Dim i&, ii&, pos                             ' array counters, element position
    ReDim tmp(0 To UBound(titles) - 1)
    If StartWithOtherCols Then
        DeleteOtherCols = False                  ' correct possible input error
        ii = UBound(titles) - UBound(colOrdr) - 1 ' << EDITED: get start counter
    End If
    For i = 0 To UBound(colOrdr)                 ' loop through titles in wanted order
        pos = Application.Match(colOrdr(i), titles, 0) ' check positions
        If Not IsError(pos) Then tmp(ii) = pos: ii = ii + 1 ' remember found positions, increment counter
    Next i
    'options
    If DeleteOtherCols Then                      ' delete non-listed columns
        ReDim Preserve tmp(0 To UBound(colOrdr)) ' remove empty elements
    Else                                         ' preserve non-listed columns
        Dim tmp2
        tmp2 = Application.Match(titles, colOrdr, 0)
        If StartWithOtherCols Then ii = 0        ' start with other columns
        For i = LBound(tmp2) To UBound(tmp2)     ' loop through titles
            If IsError(tmp2(i)) Then tmp(ii) = i: ii = ii + 1
        Next i
    End If
    getColNums = tmp                             ' return array with current column numbers (1-based)

End Function