Re-arranging the columns as per columns given in another worsheet

[sindhuja]

Hi,
can some one assist with the below requirement.

I have attached the sample spreadsheet for the reference in which we have three tabs Actual, expected and rearrange.

In rearrange sheet i have the column names according to which the columns to be arranged in expected sheet. There might be more than one occurrence of the column ex hdng9 appear twice in the expected.

Once the columns has been rearranged, we need to delete the actual and the rearrange sheet.

Formatting of the sheet should be Times new roman always with font size 8, contents left aligned. Once all these done, should ask for the save as option to save the file.

-sindhuja

[mancubus]

hi.


Sub copy_matching_cols()
'http://www.vbaexpress.com/forum/showthread.php?t=41390

Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim fCell As Range, cll As Range
Dim LR As Long

Set ws1 = Sheets("Actual")
Set ws2 = Sheets("Output")
Set ws3 = Sheets("Rearrange")

ws2.Cells.Clear
Range(ws3.Range("A2"), ws3.Range("A2").End(xlDown)).Copy
Sheets("Output").Range("A1").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Application.CutCopyMode = False

For Each cll In Range(ws2.Range("A1"), ws2.Range("IV1").End(xlToLeft))
With ws1
Set fCell = .Rows(1).Find(What:=cll.Value, LookAt:=xlWhole)
If Not fCell Is Nothing Then
LR = .Cells(.Rows.Count, fCell.Column).End(xlUp).Row
.Range(.Cells(2, fCell.Column), .Cells(LR, fCell.Column)).Copy _
Destination:=ws2.Cells(2, cll.Column)
End If
End With
Next

Application.DisplayAlerts = False 'deletes "Actual" and "Rearrange" sheets without warning
ws1.Delete
ws3.Delete
Application.DisplayAlerts = True

With ws2.Cells
.Font.Name = "Times New Roman"
.Font.Size = 8
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With

ChDir "C:\Documents\My Documents\xxx\xxxxx\" 'change to suit
Application.GetSaveAsFilename

End Sub

[Bob Phillips]

Another way


Sub rearrange()
Dim vecColumns As Variant
Dim cell As Range
Dim lastrow As Long
Dim i As Long

With Worksheets("Rearrange")

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim vecColumns(1 To lastrow - 1)
For i = 2 To lastrow

vecColumns(i - 1) = Application.Match(.Cells(i, "A"), Worksheets("Actual").Rows(1), 0)
Next i
End With

With ActiveSheet

With .UsedRange
.Value = Application.Index(.Value, _
.Parent.Evaluate("ROW(" & .Columns(1).Address & ")"), _
vecColumns)

End With

For Each cell In .UsedRange

If Application.IsNA(cell) Then cell.ClearContents
Next cell
End With
End Sub