Moving Columns Macro

[miss_mas]

Hi, there.

I am attempting to set a macro to move columns in one spreadsheet to match
the column heading order in a different spreadsheet. If the secondary
spreadsheet always came in the same order, I could just move all of the
columns once and record the macro. However, the secondary spreadsheet column
headings are in no standard order once it is received, but must be in the
same order as the primary spreadsheet when finished. Is there a way I can
set up a macro to search for the column heading and then move it to the
appropriate place to be in the same order as the primary spreadsheet?

 

[miss_mas]

Here is a visual picture of what I am attempting to do:

Report Standard Column Headings
first_name last_name address state zip age birthdate
occupation

Report 1
last_name first_name age birthdate occupation address
state zip

Report 2
birthdate age occupation first_name last_name address state zip


Is this even possible? Any feedback would be greatly appreciated.
Thanks.

 

[marcus]

Hi miss_mas

If the sheet you want to normalise only has the columns you mentioned
you could move the columns into the correct order in another part of
the sheet. This code places the colmns in the correct order from Row
R onwards then deletes Column A to Q.

Hope this helps.

Marcus



Option Compare Text
Sub CorrectCol()

Dim Lastcol As Long

Lastcol = Cells(1, Columns.Count).End(xlToLeft).Column

For i = Lastcol To 1 Step -1
If Cells(1, i).Value = "first_name" Then
Cells(1, i).EntireColumn.Copy Columns("R:R")
ElseIf Cells(1, i).Value = "last_name" Then
Cells(1, i).EntireColumn.Copy Columns("S:S")
ElseIf Cells(1, i).Value = "address" Then
Cells(1, i).EntireColumn.Copy Columns("T:T")
ElseIf Cells(1, i).Value = "state" Then
Cells(1, i).EntireColumn.Copy Columns("U:U")
ElseIf Cells(1, i).Value = "zip" Then
Cells(1, i).EntireColumn.Copy Columns("V:V")
ElseIf Cells(1, i).Value = "birthdate" Then
Cells(1, i).EntireColumn.Copy Columns("W:W")
ElseIf Cells(1, i).Value = "age" Then
Cells(1, i).EntireColumn.Copy Columns("X:X")
ElseIf Cells(1, i).Value = "occupation" Then
Cells(1, i).EntireColumn.Copy Columns("Y:Y")
End If
Next i
Range("A:Q").EntireColumn.Delete
End Sub

 

[miss_mas]

This did the trick. It was exactly what I needed.
Marcus, you are awesome!!!!!