Multiple Sheets -rearrange columns in the same order

[rokunation]

Hello everyone and thanks for your help in advance.
So my issue is as follows:
I have 4 files that contains the following columns (but some of the columns in a few files are not in the same order).

My objective is to rearrange all columns/headers to be exactly at the same order to be able to analyse the data.

Illustration:

Awaiting Delivery
UNIT_NO	YEAR	MAKE	MODEL	CATEGORY	CAT_DESC	CATEGORY_CLASS	CAT_GRP	CAT_GRP_DESC	TECH_SPEC	TS_DESC	AGE	IN SERV DT	UNIT_TYPE	FUEL_PRODUCT	CLASS5_DESC	VIN	ENGINE_SERIAL	STATUS_DESC	MAINT_LOC	MAINT_LOC_NAME	HIGH_PRIORITY	USING_DEPT_NO	USING_DEPT	OWNING_DEPT_NO	OWNING_DEPT

Cell	Condition	Cell Format	Stop If True
Cells with Conditional Formatting
Q1	Expression	=#REF!="Y"	text	NO
V1:V1043271,A1:A1043271	Expression	=$V1="Y"	text	NO

 

[HighAndWilder]

Do all of the worksheets in the 4 files to be reordered?

Do you have one sheet in which the columns are in the right order?

 

[rokunation]

Yes I can have one sheet in the right order. Then the rest can follow?

 

[HighAndWilder]

Give this a go on a copy of your workbooks.

Put this code into the workbook that has the worksheet with the correct column headings in it.

Change lines 16 and 20 as indicated in the notes in the code.

Open all of the other workbooks that need to be corrected.

Private Sub subReorderColumns()
Dim arrColumnOrder As Variant
Dim i As Integer
Dim rngFound As Range
Dim counter As Integer
Dim WbActive As Workbook
Dim WsActive As Worksheet
Dim Wb As Workbook
Dim Ws As Worksheet

    ActiveWorkbook.Save
    
    ' Change this to the workbook containing the worksheet with
    ' the correct columns headings.
    Set WbActive = Workbooks("RearrangeColumns.xlsm")
    WbActive.Activate
    
    ' Change this to the worksheet with the correct columns headings.
    Set WsActive = Worksheets("ColumnHeadings")
    WsActive.Activate
    
    If MsgBox("Is this the worksheet that you want to set the order of columns from?", vbYesNo, "Question?") = vbNo Then
        Exit Sub
    End If
    
    arrColumnOrder = WsActive.Range("A1").CurrentRegion.Rows(1)
   
    counter = 1
       
    For Each Wb In Workbooks
        
        If Wb.Name <> WbActive.Name Then

            For Each Ws In Wb.Worksheets
            
                counter = 1
                        
                For i = LBound(arrColumnOrder, 2) To UBound(arrColumnOrder, 2)
                    
                    Set rngFound = Ws.Rows("1:1").Find(arrColumnOrder(1, i), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True)
                    
                    If Not rngFound Is Nothing Then
                        
                        rngFound.Offset(1, 0) = i
                        
                        If rngFound.Column <> counter Then
                            
                            rngFound.EntireColumn.Cut
                            Ws.Columns(counter).Insert Shift:=xlToRight
                            Application.CutCopyMode = False
                        
                        End If
                        
                        counter = counter + 1
                    
                    End If
                
                Next i
                
            Next Ws
      
        End If
        
    Next Wb
    
    MsgBox "Finished", vbInformation, "Confirmation"

End Sub

 

[rokunation]

what do you mean by Change lines 16 and 20 as indicated in the notes in the code.

 

[HighAndWilder]

what do you mean by Change lines 16 and 20 as indicated in the notes in the code.

This line:
Set WbActive = Workbooks("RearrangeColumns.xlsm")

Change 'RearrangeColumns.xlsm' to the name of your workbook containing the code and the correct list of columns in row one.

Also this line:
Set WsActive = Worksheets("ColumnHeadings")

Change 'ColumnHeadings' to the name of the worksheet containing the correct list of columns in row one.

 

[rokunation]

Great! Anyway to put in the missing column in the worksheets if its missing?

 

[rokunation]

So the template has 27 columns, i want all the worksheets to have 27 columns as well even though they will be blank, just to have a uniform order in all worksheets

 

[HighAndWilder]

Does this work for you?

Private Sub subReorderColumns()
Dim arrColumnOrder As Variant
Dim i As Integer
Dim rngFound As Range
Dim counter As Integer
Dim WbActive As Workbook
Dim WsActive As Worksheet
Dim Wb As Workbook
Dim Ws As Worksheet

      ActiveWorkbook.Save
    
    ' Change this to the workbook containing the worksheet with
    ' the correct columns headings.
    Set WbActive = Workbooks("RearrangeColumns.xlsm")
    WbActive.Activate
    
    ' Change this to the worksheet with the correct columns headings.
    Set WsActive = Worksheets("ColumnHeadings")
    WsActive.Activate
    
    If MsgBox("Is this the worksheet that you want to set the order of columns from?", vbYesNo, "Question?") = vbNo Then
        Exit Sub
    End If
    
    arrColumnOrder = WsActive.Range("A1").CurrentRegion.Rows(1)
   
    counter = 1
    
    ' Loop through all workbooks.
    For Each Wb In Workbooks
        
        If Wb.Name <> WbActive.Name Then
            
            Wb.Activate

            ' Loop throigh all worksheets in each workbook.
            For Each Ws In Wb.Worksheets
            
            Ws.Activate
            
                counter = 1
                        
            For i = LBound(arrColumnOrder, 2) To UBound(arrColumnOrder, 2)
                    
                Set rngFound = Ws.Rows("1:1").Find(arrColumnOrder(1, i), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True)
                    
                If Not rngFound Is Nothing Then
                                                
                    If rngFound.Column <> counter Then
                            
                        ' Cut column that needs to be removed.
                        rngFound.EntireColumn.Cut
                            
                        ' Insert column where it should be.
                        Ws.Columns(counter).Insert Shift:=xlToRight
                            
                        Application.CutCopyMode = False
                        
                    End If
                        
                    counter = counter + 1
                    
                Else
                        
                    ' Insert Column.
                    Ws.Columns(counter).Insert Shift:=xlToRight
                        
                    ' Set heading for new column.
                    Ws.Cells(1, counter).Value = arrColumnOrder(1, i)
                        
                    ' Set interior colour, font name and size.
                    Ws.Cells(1, counter).Interior.Color = Ws.Cells(1, counter).Offset(0, 1).Interior.Color
                    Ws.Cells(1, counter).Font.Name = Ws.Cells(1, counter).Offset(0, 1).Font.Name
                    Ws.Cells(1, counter).Font.Size = Ws.Cells(1, counter).Offset(0, 1).Font.Size
                          
                    counter = counter + 1
                                
                End If
                
            Next i
                
                Ws.Range("A1").CurrentRegion.EntireColumn.AutoFit
                
        Next Ws
      
    End If
        
    Next Wb
    
    MsgBox "Column rearrangement complete.", vbInformation, "Confirmation"

End Sub