Вы не должны Select и Activate диапазоны
Процесс перемещения столбцов может быть таким:
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
Измените константу CN вверху, чтобы включить все столбцы, которые нужно переместить
До
После
Примечание. Если имя столбца содержит несколько строк текста, к константе CN можно добавить только первую строку. Вы также можете определить имя каждого отдельного столбца с несколькими строками текста, как я определил его в переменной cn1
Это также работает:
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