Sub RearrangeColumnOrder()
'
Dim ColumnNumber As Long, ResultSheetColumnNumber As Long
Dim LastColumnOfDesiredColumns As Long, LastColumnOfInputColumns As Long
Dim FoundHeaderColumnAddress As Range
Dim Search_Header As String
Dim wsInput As Worksheet, wsSource As Worksheet
'
Const HeaderRow As Long = 1 ' <--- Set this to the row that the header row is in
Const ResultSheet As String = "ResultSheet" ' <--- Set this to the sheet name of the result sheet
'
Set wsInput = Sheets("Sheet2") ' <--- Set this to the sheet with the messed up column order
Set wsSource = Sheets("Sheet1") ' <--- Set this to the sheet that has the columns in the order that you desire
'
Application.ScreenUpdating = False ' Turn ScreenUpdating offf
'
Sheets.Add(After:=Sheets(Sheets.Count)).Name = ResultSheet ' Add the result sheet to the workbook
'
LastColumnOfDesiredColumns = wsSource.Cells(1, Columns.Count).End(xlToLeft).Column ' Get last column # of the source sheet
LastColumnOfInputColumns = wsInput.Cells(1, Columns.Count).End(xlToLeft).Column ' Get last column # of the input sheet
'
For ColumnNumber = 1 To LastColumnOfDesiredColumns ' Loop through the desired columns order
Search_Header = wsSource.Cells(1, ColumnNumber) ' Get the desired Header name
'
With wsInput
Set FoundHeaderColumnAddress = .Range(.Cells(1, 1), .Cells(1, _
LastColumnOfInputColumns)).Find(Search_Header, LookIn:=xlValues) ' Find the desired column header address from the wsSource
'
If (Not FoundHeaderColumnAddress Is Nothing) Then ' If the header is found then ...
ResultSheetColumnNumber = ResultSheetColumnNumber + 1 ' Increment ResultSheetColumnNumber
.Cells(1, FoundHeaderColumnAddress.Column).EntireColumn.Copy _
Sheets(ResultSheet).Cells(1, ResultSheetColumnNumber) ' Save the desired column to the new sheet
End If
End With
Next ' Loop back
'
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
End Sub