Need Macro Help for making Transpose List

[rohit1409]

Dear All Macro Guru's,

I have a file in the following format

A B C D
1 CostCentre Basic HRA Fixed
2 880001 3000 1000 1500
3 880002 4000 2000 2500
4 880003 1000 5500 3500
5 880004 400 200 4500
6 880005 500 750 500


Output required using macro...

CostCentre Account Amount
880001 Basic 3000
880002 Basic 4000
880003 Basic 1000
880004 Basic 400
880005 Basic 500
880001 HRA 3000
880002 HRA 4000
880003 HRA 1000
880004 HRA 400
880005 HRA 500
880001 Fixed 1500
880002 Fixed 2500
880003 Fixed 3500
880004 Fixed 4500
880005 Fixed 500


Now the catch is "cost center" field is not fixed and nor does the "account heads" fields Basic, HRA, Fixed.. these can be more or less... the range can extends to 50 cost centers and 25 account heads...

Request you to kindly suggest a macro for the same... appreciate your help here...

Please let me know if any other information is required... Thanks

[snb]

It has been answered so many times for your fellow countrymen, please use this forum's search function.

We don't like crossposting:

http://www.excelguru.ca/forums/showt...Transpose-List

[p45cal]

wholesale cross posting sans links:
http://www.excelguru.ca/forums/showt...ed=1#post27162
http://answers.microsoft.com/en-us/o...c1a6ba8?auth=1
http://www.mrexcel.com/forum/excel-q...pose-list.html
http://www.ozgrid.com/forum/showthread.php?t=200951

[Paul_Hossler]

In case you didn't get an answer on the other forums

Option Explicit

Sub OnceAgain_WithFeeling()

    Dim rData As Range, rSort As Range, rSort1 As Range
    Dim wsData As Worksheet, wsOut As Worksheet
    Dim iRow As Long, iCol As Long, iOut As Long
    
    Application.ScreenUpdating = False
    
    Set wsData = ActiveSheet
    Set rData = wsData.Cells(1, 1).CurrentRegion
    Application.DisplayAlerts = False
    On Error Resume Next
    Worksheets(wsData.Name & "_List").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    Worksheets.Add.Name = wsData.Name & "_List"
    Set wsOut = Worksheets(wsData.Name & "_List")
    iOut = 1
    With wsOut
        .Cells(iOut, 1).Value = "Cost Center"
        .Cells(iOut, 2).Value = "Account"
        .Cells(iOut, 3).Value = "Amount"
        iOut = iOut + 1
        
        For iRow = 2 To rData.Rows.Count
            For iCol = 2 To rData.Columns.Count
                .Cells(iOut, 1).Value = rData.Cells(iRow, 1).Value
                .Cells(iOut, 2).Value = rData.Cells(1, iCol).Value
                .Cells(iOut, 3).Value = rData.Cells(iRow, iCol).Value
                iOut = iOut + 1
            Next iCol
        Next iRow
    
        Set rSort = .Cells(1, 1).CurrentRegion
        Set rSort1 = rSort.Cells(2, 1).Resize(rSort.Rows.Count - 1, rSort.Columns.Count)
    
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=rSort1.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add Key:=rSort1.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    
            .SetRange rSort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    
        .Range("A2").Select
        ActiveWindow.FreezePanes = True
        .Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
    
    End With
    Application.ScreenUpdating = True
End Sub