Re-arrange columns by header row via macro

[Jak]

Hello All

I am looking for advice and or examples on how to arrange columns by criteria. The criteria is the name in the header row assigned to each column and the arrangement is to be made via macro code.

On an Excel spreadsheet the titles below will be situated above a column anywhere on the spreadsheet. Unfortunately they will not be in the order below and there will be additional headings.

Column 1 = Forename
Column 2 = Initial
Column 3 = Surname
Column 4 = DOB
Column 5 = Ethnicity
Column 6 = Gender
Column 7 = Centre Candidate Id.

Therefore I need to delete all the columns that do not have one of the header titles listed above and then re-arrange the columns on the spreadsheet so that they match the criteria above.

i.e. lets say row 1 header row had titles arranged as such:

Ethnicity, Sales Tax, Initial, Forecast, Product Id, Forename, DOB, Centre Candidate Id., Surname, Gender

I would need to delete columns headed with:

Sales Tax, Forecast, Poduct Id

Thereafter I would be left with:

Ethnicity, Initial, Forename, DOB, Centre Candidate Id., Surname, Gender

I would then need to arrange these columns so that they read:

Forename, Initial, Surname, DOB, Ethnicity, Gender, Centre Candidate Id.

I need to do this via a macro and would appreciate any thoughts on how best to do this.

If this is not clear, please post your questions. Cheers.

 

[acw]

Hi

See if this gets you going.

Sub aaa()
  Application.ScreenUpdating = False
  KeepArr = Array("Forename", "Initial", "Surname", "DOB", "Ethnicity", "Gender", "Centre Candidate ID.")
  For i = Cells(1, Columns.Count).End(xlToLeft).Column To 1 Step -1
    holder = 0
    On Error Resume Next
    holder = WorksheetFunction.Match(Cells(1, i), KeepArr, 0)
    On Error GoTo 0
    If holder = 0 Then Cells(1, i).EntireColumn.Delete
  
  Next i
  Rows("1:1").Insert
  lastcol = Cells(2, Columns.Count).End(xlToLeft).Column
  For i = 1 To lastcol
   Cells(1, i).Value = WorksheetFunction.Match(Cells(2, i), KeepArr, 0)
  Next i
  Range("a1", Cells(1, lastcol)).Entirecolumn.Sort key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
  Rows("1:1").Delete
  Range("A1").Select
  Application.ScreenUpdating = False
End Sub

Tony

 

[stanleydgromjr]

Tony,

Very nicely done. Very fast.

One thing. The sort is not sorting the column headings, just the column numbers in row 1.

Test Data in their respective columns, A-J:
Ethnicity, Sales Tax, Initial, Forecast, Product Id, Forename, DOB, Centre Candidate Id., Surname, Gender

After the delete of un-neccessary column headings:

Before Sort:
A B C D E F
G

5 2 1 4 7 3
6
Ethnicity Initial Forename DOB Centre Candidate Id. Surname Gender


After the sort:
A B C D E F
G

1 2 3 4 5 6
7
Ethnicity Initial Forename DOB Centre Candidate Id. Surname Gender



Have a great day,
Stan

 

[acw]

Stan

Thanks

I've edited the code above.


Tony

 

[Jak]

Wow. Cheers acw. I was not expecting a full solution, it works brilliantly. Thanks so much for your help.

Also thanks to stanleydgromjr for the debug, great stuff.