Rearrange columns based on headers-CodePudding

I'd like to rearrange the columns' order based on their header names. Is it possible to create a blank column if the column is included in the array but not on the workbook? For example, if correctOrder() = Array("Sample 1", "Sample 2", "Sample 3", "Sample 4") and sample 4 does not exist in the workbook, a blank column will be created.

Dim correctOrder() As Variant
Dim lastCol As Long
Dim headerRng As Range, cel As Range
Dim mainWS As Worksheet

Set mainWS = ThisWorkbook.Worksheets("Sheet1")

' Edit this to be the correct order you need
correctOrder() = Array("Sample 1", "Sample 2", "Sample 3")

With mainWS
    lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set headerRng = .Range(.Cells(1, 1), .Cells(1, lastCol))
End With

Dim newWS As Worksheet
Set newWS = ThisWorkbook.Sheets.Add
newWS.Name = "Rearranged Sheet"

Dim col As Long
With newWS
    For col = 1 To lastCol
        For Each cel In headerRng
            If cel.Value = correctOrder(col - 1) Then
                mainWS.Columns(cel.Column).Copy .Columns(col)
                Exit For
            End If
        Next cel
    Next col
End With```

CodePudding user response：

Please, test the next code:

Sub matchColumnsSh()
  Dim correctOrder(), lastCol As Long, arrHd, mainWS As Worksheet
  
  Set mainWS = ThisWorkbook.Worksheets("Sheet1")

 ' Edit this to be the correct order you need (not existing sheetes included):
 correctOrder() = Array("Sample 1", "Sample 2", "Test1", "Sample 3", "Test2")

 With mainWS
    lastCol = .cells(1, .Columns.count).End(xlToLeft).Column 'last column
    arrHd = .Range(.cells(1, 1), .cells(1, lastCol)).Value         'place the headers in an array
 End With

Dim newWS As Worksheet
Set newWS = ThisWorkbook.Sheets.Add
newWS.Name = "Rearranged Sheet"

Dim col As Long, mtch
With newWS
    For col = 1 To UBound(correctOrder)   1                           'iterate between the array elements
        mtch = Application.match(correctOrder(col - 1), arrHd, 0)  'if a martch is found:
        If IsNumeric(mtch) Then
            mainWS.Columns(mtch).Copy .Columns(col)                'copy the matched column in its place
        Else
            .cells(1, col).Value = correctOrder(col - 1)                   'only write the column header
        End If
    Next col
 End With
End Sub