Move Columns Based on Header

[Michael151]

<!--[if gte mso 9]><xml> <w:WordDocument> <w:View>Normal</w:View> <w:Zoom>0</w:Zoom> <w:Compatibility> <w:BreakWrappedTables/> <w:SnapToGridInCell/> <w:WrapTextWithPunct/> <w:UseAsianBreakRules/> </w:Compatibility> <w:BrowserLevel>MicrosoftInternetExplorer4</w:BrowserLevel> </w:WordDocument> </xml><![endif]--><!--[if gte mso 10]> <style> /* Style Definitions */ table.MsoNormalTable {mso-style-name:"Table Normal"; mso-tstyle-rowband-size:0; mso-tstyle-colband-size:0; mso-style-noshow:yes; mso-style-parent:""; mso-padding-alt:0in 5.4pt 0in 5.4pt; mso-para-margin:0in; mso-para-margin-bottom:.0001pt; mso-pagination:widow-orphan; font-size:10.0pt; font-family:"Times New Roman";} </style> <![endif]--> Hello all,

Just need a little help writing a macro that will rearrange columns in a worksheet based on the header.

Currently, my worksheets have up to 10 different unique column headers that need to be in a specific order (after running the macro).

However, the worksheets may not always contain all 10 unique headers, sometimes only 6 or 8. If this is the case, the macro should simply place the columns in order (skipping over those columns missing).

For example:

DFACBE becomes: ABCDEF

DFABE becomes: ABDEF

If columns need to be placed in a specific column, maybe a separate function that will delete empty columns if needed.

Any help would be most appreciated – thanks!

 

[AlphaFrog]

Replace the "Header1", "Header2"...etc., with the actual names of your column headers and place them in the order you want as a result.

Sub Reorder_Columns()
    
    Dim arrColOrder As Variant, ndx As Integer
    Dim Found As Range, counter As Integer
    
    arrColOrder = Array([COLOR="Red"]"Header1", "Header2", "Header3", "Header4", "Header5", _
                        "Header6", "Header7", "Header8", "Header9", "Header10"[/COLOR])
    
    counter = 1
    
    Application.ScreenUpdating = False
    
    For ndx = LBound(arrColOrder) To UBound(arrColOrder)
    
        Set Found = Rows("1:1").Find(arrColOrder(ndx), LookIn:=xlValues, LookAt:=xlWhole, _
                          SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
        
        If Not Found Is Nothing Then
            If Found.Column <> counter Then
                Found.EntireColumn.Cut
                Columns(counter).Insert Shift:=xlToRight
                Application.CutCopyMode = False
            End If
            counter = counter + 1
        End If
        
    Next ndx
    
    Application.ScreenUpdating = True
    
End Sub

 

[Michael151]

Awesome AlphaFrog! Again, thanks so much for all your help!

 

[Shaner73]

AlphaFrog...

I use this macro frequently. I am training other employees the function of this macro. However, I am running into a problem. After I run this, I do a Subtotal. Whatever data I use to Subtotal, I do a Find and Replace afterwards to delete, for example, (space)Count in whatever column the Subtotal ran in.

I get the following Error Message...

Microsoft Office Excel cannot find any data to replace. Check if your search formatting and criteria are defined correctly.If you are sure the matching data exists in this workbook, it may be on a protected sheet. Excel cannot replace data on a protected worksheet.

I have checked and the sheet is not protected. I can use a different code to rearrange the headers, but I like this one much better.

Any help will be appreciated.

Thanks,
Shane

 

[AlphaFrog]

... I do a Find and Replace afterwards to delete, for example, (space)Count in whatever column the Subtotal ran in.

The message means it can't find anything that matches your search criteria; (space)Count.
I don't understand what you are searching for, but your search for criteria, (space)Count, is probably what needs to be changed.

 

[Shaner73]

The message means it can't find anything that matches your search criteria; (space)Count.
I don't understand what you are searching for, but your search for criteria, (space)Count, is probably what needs to be changed.

When I run a subtotal, I need to delete the " Count" or ' Average"...whatever I am subtotaling in that column.

The other macro that is run by another person uses the .Select method...or Cut and Paste. We can subtotal, then Find and Replace with no errors.

Is it possible that your macro changes something by using an array?

We like your macro as it's easier to maintain and it's faster.

 

[AlphaFrog]

When I run a subtotal, I need to delete the " Count" or ' Average"...whatever I am subtotaling in that column.

The other macro that is run by another person uses the .Select method...or Cut and Paste. We can subtotal, then Find and Replace with no errors.

Is it possible that your macro changes something by using an array?

We like your macro as it's easier to maintain and it's faster.

Sorry but I am not following at all what you are doing or want to do. What other macro?

As a total guess, if you want to search within the formulas, change this...
LookIn:=xlValues

To this...
LookIn:=xlFormulas

 

[Shaner73]

Sorry but I am not following at all what you are doing or want to do. What other macro?

As a total guess, if you want to search within the formulas, change this...
LookIn:=xlValues

To this...
LookIn:=xlFormulas

Sorry I'm not being clear enough...I'm not sure any other way to explain what I'm doing. Thank you for trying to help...but changing Values to Formulas did not work. I appreciate it!

 

[Vexorg]

Hi Guys,

This worked very well for me and I was able to rearrange the columns as i had specified. Is it possible to insert a blank column into the string as a place holder?

So IE "Column1", "(place holders)", "Column3" etc

 

[AlphaFrog]

It's probably easiest to insert blank columns after sorting the columns with headers.

Sub Reorder_Columns()
    
    Dim arrColOrder As Variant, ndx As Integer
    Dim Found As Range, counter As Integer
    
    arrColOrder = Array("Header1", "Header2", "Header3", "Header4", "Header5", _
                        "Header6", "Header7", "Header8", "Header9", "Header10")
    
    counter = 1
    
    Application.ScreenUpdating = False
    
    For ndx = LBound(arrColOrder) To UBound(arrColOrder)
    
        Set Found = Rows("1:1").Find(arrColOrder(ndx), LookIn:=xlValues, LookAt:=xlWhole, _
                          SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
        
        If Not Found Is Nothing Then
            If Found.Column <> counter Then
                Found.EntireColumn.Cut
                Columns(counter).Insert Shift:=xlToRight
                Application.CutCopyMode = False
            End If
            counter = counter + 1
        End If
        
    Next ndx
    
    [COLOR="Green"]' Insert blank column B[/COLOR]
    [COLOR="Red"]Columns("B:B").Insert Shift:=xlToRight[/COLOR]

    Application.ScreenUpdating = True
    
End Sub