You shouldn't Select and Activate ranges
The process of moving columns can be like this
Option Explicit
Public Sub MoveColumns1()
Const SDEL = "|||" 'column names cannot contain the delim chars ("|||")
Const CN = "Col2" & SDEL & "Col1 `!@#$%^&*()_+-={}[];':"""",./<>?"
Dim ws As Worksheet, cols As Variant, arr As Variant, newStart As Long, cnX As String
Dim trim1 As String, trim2 As String, i As Long, j As Long, cn1 As String
Set ws = Sheet1 'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
cn1 = "Col3 - Line 1" & Chr(10) & "Col3 - Line 2" & Chr(10) & "Col3 - Line 3"
cnX = cn1 & SDEL & CN 'Header with multiple lines of text, separated by Chr(10)
cols = Split(cnX, SDEL) '0-based array containing names defined in cnX
arr = ws.Range(ws.Cells(1), ws.Cells(1, ws.Columns.Count).End(xlToLeft)) 'hdr row (1)
Application.ScreenUpdating = False 'Turn screen Off
For i = 1 To UBound(arr, 2) 'Iterate all Header cells (in row 1)
trim1 = Trim$(arr(1, i)) 'Trim left/right white-spaces from each Header
For j = 0 To UBound(cols) 'Iterate each name defined in cnX
trim2 = Trim$(cols(j)) 'Trim left/right white spaces in current cnX
If Len(trim1) >= Len(trim2) Then 'If Header is longer than current cnX
If InStrB(1, trim1, trim2) > 0 Then 'If Header contains current cnX
ws.Cells(i).EntireColumn.Cut 'Copy current cnX column (i)
ws.Cells(1).Insert Shift:=xlToRight 'Paste column as first (1)
newStart = Len(cnX) - (InStr(1, cnX, trim2) + Len(trim2) + Len(SDEL) - 1)
If newStart < 1 Then Exit Sub 'If the cnX list is empty, we are done
cols = Split(Right(cnX, newStart), SDEL) 'Remove current cnX
Exit For 'Done with current cnX
End If
End If
Next
Next
Application.ScreenUpdating = False 'Turn screen back On
End Sub
Modify the constant CN at the top to include all columns to be moved
Before
After
Note: If a column name contains multiple lines of text, you can add just the first line to the constant CN. You can also define each individual column name with multiple lines of text as I defined it in variable cn1
This also works:
Public Sub MoveColumns2()
Const SDEL = "|||" 'column names cannot contain the delim chars ("|||")
Const CN = "Col3 - Line 1" & SDEL & "Col2" & SDEL & "Col1 `!@#$%^&*()_+-={}[];':"""",./<>?"
Dim ws As Worksheet, cols As Variant, arr As Variant, newStart As Long, cnX As String
Dim trim1 As String, trim2 As String, i As Long, j As Long, cn1 As String
Set ws = Sheet1 'Or: Set ws = ThisWorkbook.Worksheets("Sheet1")
cnX = CN 'Header with multiple lines of text, separated by Chr(10)
cols = Split(cnX, SDEL) '0-based array containing names defined in cnX
arr = ws.Range(ws.Cells(1), ws.Cells(1, ws.Columns.Count).End(xlToLeft)) 'hdr row (1)
Application.ScreenUpdating = False 'Turn screen Off
For i = 1 To UBound(arr, 2) 'Iterate all Header cells (in row 1)
trim1 = Trim$(arr(1, i)) 'Trim left/right white-spaces from each Header
For j = 0 To UBound(cols) 'Iterate each name defined in cnX
trim2 = Trim$(cols(j)) 'Trim left/right white spaces in current cnX
If Len(trim1) >= Len(trim2) Then 'If Header is longer than current cnX
If InStrB(1, trim1, trim2) > 0 Then 'If Header contains current cnX
ws.Cells(i).EntireColumn.Cut 'Copy current cnX column (i)
ws.Cells(1).Insert Shift:=xlToRight 'Paste column as first (1)
newStart = Len(cnX) - (InStr(1, cnX, trim2) + Len(trim2) + Len(SDEL) - 1)
If newStart < 1 Then Exit Sub 'If the cnX list is empty, we are done
cols = Split(Right(cnX, newStart), SDEL) 'Remove current cnX
Exit For 'Done with current cnX
End If
End If
Next
Next
Application.ScreenUpdating = False 'Turn screen back On
End Sub
