rearrange Columns according to predefined order

[Guest]

I have a file lets name it file One Xl Sheet that has 10 Colums and Another
file two one that has 50
I would liketo rearrange the file one colums in such an order to match the
order in file B. So for example input
File One
A B C D
SSn Name last name Age
File Two
A B C D E F
record num Age Name City Last Name SSn


File One Should be converted
A B C D E
F
record num (blank) Age Name City(blank) Last Name SSn


I need to compare the 2 files and unless they get the same order this is not
possible.

 

[Bernie Deitrick]

stratis,

Put the code below into an otherwise blank workbook, then run the macro. It will prompt you to
select the two workbooks to open (so they should not be open already): File One first, then File
Two.

HTH,
Bernie
MS Excel MVP

Sub SortColumnsToMatchOrder()
Dim File1 As Workbook
Dim File2 As Workbook
Dim i As Integer
Dim myR As Range

Set File1 = Workbooks.Open(Application.GetOpenFilename( _
, , "Select File 1 (To be sorted)"))
Set File2 = Workbooks.Open(Application.GetOpenFilename( _
, , "Select File 2 (with sort order)"))

With File1.Sheets(1)
.Range("A1").EntireRow.Insert
.Range(.Range("A1"), .Cells(2, Columns.Count).End(xlToLeft)(0)).Formula = _
"=MATCH(A2,'[" & File2.Name & "]" & File2.Sheets(1).Name & "'!1:1,FALSE)"

On Error GoTo NoMatchError
Set myR = .Range("1:1").SpecialCells(xlCellTypeFormulas, 16)
GoTo MatchErrors
NoMatchError:

For i = 1 To File2.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
If IsError(Application.Match(i, File1.Sheets(1).Range("1:1"), False)) Then
With .Cells(1, Columns.Count).End(xlToLeft)
.Cells(1, 2).Value = i
.Cells(2, 2).Value = File2.Sheets(1).Cells(1, i).Value
End With
End If
Next i

..Range("1:1").Value = .Range("1:1").Value

..Range("A1").CurrentRegion.Sort Key1:=.Range("A1"), _
Order1:=xlAscending, _
Header:=xlNo, _
Orientation:=xlLeftToRight, _
DataOption1:=xlSortNormal

GoTo SkipMessage
MatchErrors:
MsgBox "Not all headers were matched! - check errors in row 1 of " & .Parent.Name
Exit Sub

SkipMessage:
..Range("1:1").EntireRow.Delete
End With

End Sub