Macro to rearrange columns in sequence

Question

I am new to VBA, Macro, Excel... all I am trying is to rearrange columns in sequence... so I have declared column name at first then the column range and tried to Cut, Insert/Paste the columns by their name one after another. The macro just executes does not give the desired output, as I am predicting that columns get shuffled. Then, I tried to cut all 24 columns at once and paste them in sequence one after another which unfortunately does not work. Then, I decided to cut a range of columns from that main sheet create a new sheet and paste there then cut single columns from that sheet and paste it back in the main sheet which is also not working. I am able to cut and paste the columns in the new sheet but not able to paste the columns in sheet "Main".

My Codes 1 - This is the code I tried to copy cut paste the column which executes but does not give the result.

Option Explicit

Sub Cutpastecols()

Dim colhead1 As String
Dim colhead2 As String
Dim colhead3 As String
Dim colhead4 As String
Dim colhead5 As String

colhead1 = "Container #"
colhead2 = "Dest. City Name"
colhead3 = "Origin City Name"
colhead4 = "POD City Name"
colhead5 = "POL City Name"

Dim ch1, ch2, ch3, ch4, ch5, ch6, ch7, ch8, ch9, ch10, _
ch11, ch12, ch13, ch14, ch15, ch16, ch17, ch18, ch19, ch20, _
ch21, ch22, ch23, ch24 As String

'1 Full In Gate at Inland or Interim Point (Origin) _recvd & Full In Gate at Inland or Interim Point (Origin) _actual

ch1 = "Full In Gate at Inland or Interim Point (Origin) _actual"
ch2 = "Full In Gate at Inland or Interim Point (Origin) _recvd"

'2 Full Out Gate from Ocean Terminal (CY or Port)_actual & Full Out Gate from Ocean Terminal (CY or Port)_recvd

ch3 = "Full Out Gate from Ocean Terminal (CY or Port)_actual"
ch4 = "Full Out Gate from Ocean Terminal (CY or Port)_recvd"

'3 Discharged at Port of Discharge_actual & Discharged at Port of Discharge_recvd

ch5 = "Discharged at Port of Discharge_actual"
ch6 = "Discharged at Port of Discharge_recvd"

'4 On Rail (Origin)_actual & On Rail (Origin)_recvd

ch7 = "On Rail (Origin)_actual"
ch8 = "On Rail (Origin)_recvd"

'5 Full Out Gate at Inland or Interim Point (Destination)_actual & Full Out Gate at Inland or Interim Point (Destination)_recvd

ch9 = "Full Out Gate at Inland or Interim Point (Destination)_actual"
ch10 = "Full Out Gate at Inland or Interim Point (Destination)_recvd"

'6 Full In Gate at Ocean Terminal (CY or Port)_actual & Full In Gate at Ocean Terminal (CY or Port)_recvd

ch11 = "Full In Gate at Ocean Terminal (CY or Port)_actual"
ch12 = "Full In Gate at Ocean Terminal (CY or Port)_recvd"

'7 Off Rail (Destination)_actual & Off Rail (Destination)_recvd

ch13 = "Off Rail (Destination)_actual"
ch14 = "Off Rail (Destination)_recvd"

'8 Off Rail (Origin)_actual & Off Rail (Origin)_recvd

ch15 = "Off Rail (Origin)_actual"
ch16 = "Off Rail (Origin)_recvd"

'9 On-Board Vessel at Port of Loading_actual & On-Board Vessel at Port of Loading_recvd

ch17 = "On-Board Vessel at Port of Loading_actual"
ch18 = "On-Board Vessel at Port of Loading_recvd"

'10 Vessel Arrived at Port of Discharge_actual & Vessel Arrived at Port of Discharge_recvd

ch19 = "Vessel Arrived at Port of Discharge_actual"
ch20 = "Vessel Arrived at Port of Discharge_recvd"

'11 On Rail (Destination)_actual & On Rail (Destination)_recvd

ch21 = "On Rail (Destination)_actual"
ch22 = "On Rail (Destination)_recvd"

'12 Vessel Departed from Port of Loading_actual & Vessel Departed from Port of Loading_recvd

ch23 = "Vessel Departed from Port of Loading_actual"
ch24 = "Vessel Departed from Port of Loading_recvd"

Dim colhedr1, colhedr2, colhedr3, colhedr4, colhedr5, cr1, cr2, cr3, cr4, cr5, cr6, cr7, cr8, cr9, cr10, _
cr11, cr12, cr13, cr14, cr15, cr16, cr17, cr18, cr19, cr20, _
cr21, cr22, cr23, cr24 As Range

'----- First Cut all the column----------
Set colhedr2 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(colhead2, LookIn:=xlValues)
Columns(colhedr2.Column).Cut

Set colhedr3 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(colhead3, LookIn:=xlValues)
Columns(colhedr3.Column).Cut

Set colhedr4 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(colhead4, LookIn:=xlValues)
Columns(colhedr4.Column).Cut

Set colhedr5 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(colhead5, LookIn:=xlValues)
Columns(colhedr5.Column).Cut

Set cr1 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch1, LookIn:=xlValues)
Columns(cr1.Column).Cut


Set cr2 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch2, LookIn:=xlValues)
Columns(cr2.Column).Cut

Set cr3 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch3, LookIn:=xlValues)
Columns(cr3.Column).Cut


Set cr4 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch4, LookIn:=xlValues)
Columns(cr4.Column).Cut

Set cr5 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch5, LookIn:=xlValues)
Columns(cr5.Column).Cut

Set cr6 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch6, LookIn:=xlValues)
Columns(cr6.Column).Cut

Set cr7 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch7, LookIn:=xlValues)
Columns(cr7.Column).Cut

Set cr8 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch8, LookIn:=xlValues)
Columns(cr8.Column).Cut

Set cr9 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch9, LookIn:=xlValues)
Columns(cr9.Column).Cut

Set cr10 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch10, LookIn:=xlValues)
Columns(cr10.Column).Cut

Set cr11 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch11, LookIn:=xlValues)
Columns(cr11.Column).Cut

Set cr12 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch12, LookIn:=xlValues)
Columns(cr12.Column).Cut

Set cr13 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch13, LookIn:=xlValues)
Columns(cr13.Column).Cut

Set cr14 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch14, LookIn:=xlValues)
Columns(cr14.Column).Cut

Set cr15 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch15, LookIn:=xlValues)
Columns(cr15.Column).Cut

Set cr16 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch16, LookIn:=xlValues)
Columns(cr16.Column).Cut

Set cr17 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch17, LookIn:=xlValues)
Columns(cr17.Column).Cut

Set cr18 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch18, LookIn:=xlValues)
Columns(cr18.Column).Cut

Set cr19 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch19, LookIn:=xlValues)
Columns(cr19.Column).Cut

Set cr20 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch20, LookIn:=xlValues)
Columns(cr20.Column).Cut

Set cr21 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch21, LookIn:=xlValues)
Columns(cr21.Column).Cut

Set cr22 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch22, LookIn:=xlValues)
Columns(cr22.Column).Cut

Set cr23 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch23, LookIn:=xlValues)
Columns(cr23.Column).Cut

Set cr24 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch24, LookIn:=xlValues)
Columns(cr24.Column).Cut


'-------Start pasting in sequence-----
'colhead1 dont cut colhead1 (just find colhead1 and start pasting columns after colhead1)

Set colhedr1 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(colhead1, LookIn:=xlValues)
Columns(colhedr2.Column).Insert shift:=xlToRight

Set colhedr2 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(colhead2, LookIn:=xlValues)
Columns(colhedr3.Column).Insert shift:=xlToRight

Set colhedr3 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(colhead3, LookIn:=xlValues)
Columns(colhedr4.Column).Insert shift:=xlToRight

Set colhedr4 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(colhead4, LookIn:=xlValues)
Columns(colhedr5.Column).Insert shift:=xlToRight

Set colhedr5 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(colhead5, LookIn:=xlValues)
Columns(cr1.Column).Insert shift:=xlToRight

Set cr1 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch1, LookIn:=xlValues)
Columns(cr2.Column).Insert shift:=xlToRight

Set cr2 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch2, LookIn:=xlValues)
Columns(cr3.Column).Insert shift:=xlToRight

Set cr3 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch3, LookIn:=xlValues)
Columns(cr4.Column).Insert shift:=xlToRight

Set cr4 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch4, LookIn:=xlValues)
Columns(cr5.Column).Insert shift:=xlToRight

Set cr5 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch5, LookIn:=xlValues)
Columns(cr6.Column).Insert shift:=xlToRight

Set cr6 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch6, LookIn:=xlValues)
Columns(cr7.Column).Insert shift:=xlToRight

Set cr7 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch7, LookIn:=xlValues)
Columns(cr8.Column).Insert shift:=xlToRight

Set cr8 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch8, LookIn:=xlValues)
Columns(cr9.Column).Insert shift:=xlToRight

Set cr9 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch9, LookIn:=xlValues)
Columns(cr10.Column).Insert shift:=xlToRight

Set cr10 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch10, LookIn:=xlValues)
Columns(cr11.Column).Insert shift:=xlToRight

Set cr11 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch11, LookIn:=xlValues)
Columns(cr12.Column).Insert shift:=xlToRight

Set cr12 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch12, LookIn:=xlValues)
Columns(cr13.Column).Insert shift:=xlToRight

Set cr13 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch13, LookIn:=xlValues)
Columns(cr14.Column).Insert shift:=xlToRight

Set cr14 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch14, LookIn:=xlValues)
Columns(cr15.Column).Insert shift:=xlToRight

Set cr15 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch15, LookIn:=xlValues)
Columns(cr16.Column).Insert shift:=xlToRight

Set cr16 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch16, LookIn:=xlValues)
Columns(cr17.Column).Insert shift:=xlToRight

Set cr17 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch17, LookIn:=xlValues)
Columns(cr18.Column).Insert shift:=xlToRight

Set cr18 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch18, LookIn:=xlValues)
Columns(cr19.Column).Insert shift:=xlToRight

Set cr19 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch19, LookIn:=xlValues)
Columns(cr20.Column).Insert shift:=xlToRight

Set cr20 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch20, LookIn:=xlValues)
Columns(cr21.Column).Insert shift:=xlToRight

Set cr21 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch21, LookIn:=xlValues)
Columns(cr22.Column).Insert shift:=xlToRight

Set cr22 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch22, LookIn:=xlValues)
Columns(cr23.Column).Insert shift:=xlToRight

Set cr23 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(ch23, LookIn:=xlValues)
Columns(cr24.Column).Insert shift:=xlToRight

End Sub

My Code 2 This I created in 2 modules and then call the macros... Now in this below code module 1 cuts all data from starting from column D and creates a new sheet named "Column" and paste it there. then module 2 I created that cuts the single columns from sheet module and paste it the sheet named "Main"! Unfortunately, this module 2 does not work. It creates a new sheet named column and pastes the data there but module 2 is not working neither it gives any error.

Module 1 -

Sub copy2()


Dim Source As Worksheet
Dim Destination As Worksheet
Dim Last As Long

Application.ScreenUpdating = False

'Checking whether "Master" sheet already exists in the workbook
For Each Source In ThisWorkbook.Worksheets
    If Source.Name = "Column" Then
        MsgBox "Column sheet already exist"
        Exit Sub
    End If
Next

'Inserting new worksheets in the workbook
Set Destination = Worksheets.Add(after:=Worksheets("Main"))

'Renaming the worksheet
Destination.Name = "Column"

'Looping through the worksheets in the workbook
For Each Source In ThisWorkbook.Worksheets
    
    
    If Source.Name = "Main" Then
        
        'Finding the last column from the destination sheet
        Last = Destination.Range("A1").SpecialCells(xlCellTypeLastCell).Column
        
        If Last = 1 Then
            'Pasting the data in the destination sheet
            Source.Range("D:XDF").Copy Destination.Columns(Last)
        Else
            Source.Range("D:XDF").Copy Destination.Columns(Last + 1)
        End If
    End If
Next

ActiveWorkbook.Worksheets("Main").Range("D:XDF").Delete


Columns.AutoFit

Application.ScreenUpdating = True



End Sub

Module 2

Dim lastrow As Integer, erow As Integer, sheet1 As Worksheet, sheet2 As Worksheet

Dim colhead1 As String
Dim colhead2 As String
Dim colhead3 As String
Dim colhead4 As String
Dim colhead5 As String

colhead1 = "Container #"
colhead2 = "Dest. City Name"
colhead3 = "Origin City Name"
colhead4 = "POD City Name"
colhead5 = "POL City Name"

Dim colhedr1, colhedr2, colhedr3, colhedr4, colhedr5, cr1, cr2, cr3, cr4, cr5, cr6, cr7, cr8, cr9, cr10, _
cr11, cr12, cr13, cr14, cr15, cr16, cr17, cr18, cr19, cr20, _
cr21, cr22, cr23, cr24 As Range

'----- First Cut all the column----------
Set colhedr2 = ActiveWorkbook.Worksheets("Column").Rows(1).Find(colhead2, LookIn:=xlValues)
Set colhedr1 = ActiveWorkbook.Worksheets("Main").Rows(1).Find(colhead1, LookIn:=xlValues)
Columns(colhedr2.Column).Cut
Columns(colhedr1.Column).Insert shift:=xlToRight

Module 2 I just created for 1 column and tested it does not work. Please guide and advice any easy way of solving this.

[

Answer 1

Please, test the next code. The code should be very fast, using arrays, working only in memory and dropping the processing result at once. It will return the result at the end of the sheet range, after the existing rows. After testing the code and consider it reliable, you can simple change the cell where the arrFin array content is dropped. From sh.Range("A" & lastRow + 2) in sh.Range("A1"):

Sub RearrangeColumns()
 Dim sh As Worksheet, lastCol As Long, lastRow As Long, arrH, arrH1D, arrAct
 Dim kA As Long, kR As Long, kM As Long, strRootA As String, arrRec, arrFin
 Dim arrIntA, arrIntR, arrCol() As Long, i As Long, k As Long, j As Long
 Dim arrTot, strRootR As String, arrNotM() As Long, boolNotMatch As Boolean
 
 Set sh = ThisWorkbook.Sheets("Main") 'use here the sheet you need
 
 lastCol = sh.cells(1, Columns.count).End(xlToLeft).Column 'sheet last column
 lastRow = sh.Range("A" & rows.count).End(xlUp).row        'sheet last row
 
 arrTot = sh.Range("A1", sh.cells(lastRow, lastCol)) 'put all the sheet range in an array
 arrH = sh.Range("A1", sh.cells(1, lastCol)).Value   'put the column headers in an array
 ReDim arrAct(0 To UBound(arrH, 2) - 1) 'initial redim array to keep the headers ending in "_actual"
 ReDim arrRec(0 To UBound(arrH, 2) - 1) 'initial redim array to keep the headers ending in "_recvd"
 ReDim arrNotM(0 To UBound(arrH, 2))    'redim the array to keep columns not able to match
 ReDim arrCol(0 To UBound(arrH, 2))     'redim the array to keep the necessary columns order!!!
 
 arrH1D = Application.Index(arrH, 1, 0) 'make the headers array a 1D type
 
 'Fill the arrays keeping the headers ending in "_actual", respectively, "_recvd"
 'The above mentioned arrays will also keep each column number
 For i = 1 To UBound(arrH1D)
     If LCase(Right(arrH1D(i), 7)) = "_actual" Then
        arrAct(kA) = arrH1D(i) & ";" & i: kA = kA + 1
     ElseIf LCase(Right(arrH1D(i), 6)) = "_recvd" Then
        arrRec(kR) = arrH1D(i) & ";" & i: kR = kR + 1
     Else
        arrNotM(kM) = i: kM = kM + 1: boolNotMatch = True
     End If
 Next i
 ReDim Preserve arrAct(0 To kA - 1) 'redim the array at the filled elements number
 ReDim Preserve arrRec(0 To kR - 1) 'redim the array at the filled elements number
 If boolNotMatch Then ReDim Preserve arrNotM(0 To kM - 1) 'redim the array at the filled elements number

 'Build the column order array:
 Dim boolMatch As Boolean, strNoMatch As String, arrRUsed, kk As Long
 ReDim arrRUsed(0 To UBound(arrRec)) ' I am using this way of ReDim because of
                                     ' Option Base 1 on top of the module (for other code)
 For i = 0 To UBound(arrAct)
    'split the array elements in header (arrIntA(0)) and column number (arrIntA(1))
    arrIntA = Split(arrAct(i), ";"): strRootA = left(arrIntA(0), Len(arrIntA(0)) - 7)
    arrCol(k) = CLng(arrIntA(1)): k = k + 1
    For j = 0 To UBound(arrRec) 'compare the header string roots (without the ending termination)
        arrIntR = Split(arrRec(j), ";"): strRootR = left(arrIntR(0), Len(arrIntR(0)) - 6)
        If UCase(WorksheetFunction.Trim(strRootA)) = UCase(WorksheetFunction.Trim(strRootR)) Then
             arrCol(k) = CLng(arrIntR(1)): k = k + 1: boolMatch = True 'build the columns order array
             arrRUsed(kk) = arrRec(j): kk = kk + 1: Exit For           'build the array of matching headers
        End If
    Next j
    If Not boolMatch Then
        'build the string for the matching cases:
        strNoMatch = strNoMatch & arrIntA(0) & " (on column " & arrIntA(1) & ")" & vbCrLf
    End If
    boolMatch = False 'reinitialize the variable
 Next i
 ReDim Preserve arrRUsed(kk - 1)

 Dim strMissRec As String, El, El1: kk = 0
 boolMatch = False 'reinitialize the variable
 For Each El In arrRec
    For Each El1 In arrRUsed
      If El = El1 Then boolMatch = True: Exit For 'when a match has been found
    Next
    'build the string of not matcheing headers, if the case:
    If Not boolMatch Then strMissRec = strMissRec & Split(El, ";")(0) & _
                              " (on column " & Split(El, ";")(1) & ")" & vbCrLf
    boolMatch = False
 Next

 'in case there are spelling mistakes between the headers keeping "_actual" and "_recvd".
 If strNoMatch <> "" Then
     MsgBox "The next (_Actual) header(s) could not be paired: " & vbCrLf & strNoMatch & vbCrLf & _
            "Please, correct the one of the corresponding headers, to make them matching!" & vbCrLf & _
            vbCrLf & " See the next (_recvd) headers to find the correspondence:" & vbCrLf & strMissRec
     Exit Sub
 End If
 
 ReDim Preserve arrCol(0 To k - 1 + IIf(boolNotMatch, UBound(arrNotM) + 1, 0)) 'just in case, if the above situation happens...
 Dim colsInFront As Boolean, t As Long, l As Long, ColNo As Long, arrNew() As Long
 colsInFront = True
 If colsInFront Then
    ReDim arrNew(0)
    For i = 0 To UBound(arrCol)
        If i <= UBound(arrNotM) Then
            arrNew(t) = arrCol(i): t = t + 1
            If t <= UBound(arrNotM) Then ReDim Preserve arrNew(t)
            arrCol(i) = arrNotM(i)
        Else
            ColNo = arrNew(0)
            If i <= UBound(arrCol) - (UBound(arrNotM) + 1) Then
                For l = 0 To UBound(arrNew) - 1
                    arrNew(l) = arrNew(l + 1)
                Next l
                arrNew(UBound(arrNew)) = arrCol(i)
                arrCol(i) = ColNo
            Else
              For t = 0 To UBound(arrNew)
                arrCol(UBound(arrCol) - (UBound(arrNew) - t)) = arrNew(t)
              Next
              Exit For
            End If
        End If
    Next i
 Else
    If boolNotMatch Then 'if there are column not supposing to be matching
       For i = 0 To UBound(arrNotM)
           arrCol(k + i) = arrNotM(i)
       Next
    End If
 End If
 'build the new array having columns in the necessary order:
 arrFin = Application.Index(arrTot, Evaluate("row(1:" & lastRow & ")"), arrCol())
 
 'drop the array content at once.
 Dim rngDrop As Range
 Set rngDrop = sh.Range("A" & lastRow + 2)
 With rngDrop.Resize(UBound(arrFin), UBound(arrFin, 2))
    .Value = arrFin
    .EntireColumn.AutoFit
 End With
 
 sh.Activate: sh.Range("A1").Select
 MsgBox "Ready...", vbInformation, "Job done"
End Sub

Answer 2

Restructuring including non-pairs

For the sake of readibility and in addition to @FaneDuru 's valid answer, I demonstrate a structured solution with two help functions. Both approaches use the advanced restructuring features of Application.Index() - c.f. Some pecularities of Application.Index()

Assumption is made that each ".._actual" caption is followed by its twin partner ".._recvd"

Example call RearrangeColumns

Option Explicit                       ' declaration head of your code module

Sub RearrangeColumns()
  Dim rng As Range
  Set rng = Sheet1.Range("A1:Z1000") ' << change sheet's Code(Name) and range as needed
  
  With Application
    ' [1a] create 2-dim data field array (1-based)
      Dim v As Variant
      v = rng.Value2
    ' [1b] get titles
      Dim titles As Variant
      titles = .Transpose(.Transpose(.Index(v, 1, 0)))         ' << column titles as "flat" array
    ' [1c] rearrange columns (maintaining all row items)
      v = Application.Index(v, Evaluate("row(1:" & rng.Rows.Count & ")"), getColNums(titles))
  End With
' [2] write data field back to resized range
  rng = ""                                  ' clear lines
  rng.Resize(UBound(v), UBound(v, 2)) = v   ' overwrite data with rearranged column items
End Sub

Help function getColNums()

Methodical hints (edit in response to comment)

• [0] provides for a 1-based 1-dim temporary array holding the same number of items as the passed "flat" titles array
• [1] analyzes each title
• [2] splits the current title into a left (index 0) and a right part (index 1) using the Split() function. Note the temporary addition of "_" to the first argument to allow splits of titles without a _ delimiter into two parts (where the right part can be empty, i.e. "").
• [3]checks for right parts of splitted titles and assign the found positions via Application.Match(). - Note that a non-finding results in a non-available error which can be checked in several ways (e.g. via If Application.Count(...) then identifying a valid finding as it ignores errors and returns a count of 1 if valid); see further comments in code and in explanations of the incrementing help function nxt() below.
• [4] returns function results of getColNums() as a "flat" array of all old column numbers that will be rearranged due to the numeric position in the current array.

The example call uses these getColNums() array as last argument in v = Application.Index(v, Evaluate("row(1:" & rng.Rows.Count & ")"), getColNums(titles)); the Evaluate() part is in the position to return a "vertical" array of all row items in unmodified order.

Function getColNums(titles)
'Purpose: get a "flat" array referencing the "old" column numbers 
    '[0]provide for a 1-based 1-dim temporary array holding the same number of items as titles
    Dim tmp: ReDim tmp(1 To UBound(titles))
    With Application                    ' using Application.Match and Application.Count
        Dim i As Long, ii As Long
    '[1]analyze each title
        For i = 1 To UBound(titles)
        '[2]split the current title into a left (index 0) and a right part (index 1)
            '   note the addition & "_" to allow splits of titles without a "_" delimiter
        Dim parts: parts = Split(titles(i) & "_", "_")
        '[3]check for right parts of "actual" (as 0-based, 2nd parts item has index = 1)
            If parts(1) = "actual" Then
        'a) match the position of a possible twin partner with a "_recvd" suffix
                Dim pos: pos = .Match(parts(0) & "_recvd", titles, 0)
        'b) check if such a title can be found
                If .Count(pos) Then
                'assign the "_actual" position to next tmp item
                    tmp(nxt(ii)) = i
                    'assign the "_recvd" position to next tmp item
            '(but forget it if prior to an "_actual" item, as already recorded)
                    If pos > i Then tmp(nxt(ii)) = pos
        'c) provide for the case where there is ONLY a "_actual", but no "_recvd" twin
                Else
                    tmp(nxt(ii)) = i
                End If
            ElseIf parts(1) <> "recvd" Then
        'd) provide for the case of all other titles (except for "_recvd" items) 
                tmp(nxt(ii)) = i
            End If
            'Debug.Print i, titles(i), Join(tmp, ",")    ' 
        Next i
    End With
    '[4] return function results as "flat" array
    getColNums = tmp            
End Function

---

Help function nxt()

Tries to simulate incrementing via ++ii; like in C to shorten code.

Methodical hints (edit in response to comment)

Passing an argument ByReference to a function means that the function not only can execute some operations on the passed value, but has direct access to the memory address holding here the passed variable. So changing a ByRef argument value within the function code directly changes the value of the calling code during its memory "life time".

As ByRef arguments are the default in Visual Basic it would have been possible to omit the prefixed ByRef just coding Function nxt(ii As Long) As Long.

The function itself increments the passed variable by +1 so that the calling code in this example

• a) remembers the incremented ii and
• b) can use it immediately as current index (e.g. tmp(nxt(ii)))

without boring repetions of ii = ii + 1 before each tmp item assignment to get the next item.

Function nxt(ByRef ii As Long) As Long
'Purpose: something similar to ++ii increments in C
    ii = ii + 1: nxt = ii
End Function