Need Macro for making Transpose List

[rohit1409]

Dear All Macro Guru's,

I have a file in the following format

A B C D
1 Cost Centre 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...

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

 

[Llupo01]

Hello,

all data you want to extract are in one column? I would like to see your file with original data and final result if possible. Can you pls upload test file somewhere and post link?

 

[jorismoerings]

Hi,

Assuming from your OP that your data is already in columns; try this:

Sub ConvertTabletoRows()
Dim wsOriginal As Worksheet
Dim wsConverted As Worksheet
Dim strKey As String
Dim clnHeader As Collection
Dim lngColumnCounter As Long
Dim lngRowCounterOriginal As Long
Dim lngRowCounterConverted As Long
Dim rngCurrent As Range
Dim varColumn As Variant

Set wsOriginal = ThisWorkbook.Worksheets("Original")   'This is the name of your original worksheet'
Sheets.Add.Name = "Converted"                          'This will add a sheet to copy the data to'
Set wsConverted = ThisWorkbook.Worksheets("Converted") 'This is the name of the new worksheet'
Set clnHeader = New Collection

wsConverted.Cells.ClearContents        'This deletes the contents of the destination worksheet to make sure it's empty'

lngColumnCounter = 2
lngRowCounterOriginal = 1
Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)

' We'll loop through just the headers to get a collection of header names'
Do Until IsEmpty(rngCurrent.Value)
    clnHeader.Add rngCurrent.Value, CStr(lngColumnCounter)
    lngColumnCounter = lngColumnCounter + 1
    Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)
Loop

'Here we'll reset our Row Counter and loop through the entire data set'
lngRowCounterOriginal = 2
lngRowCounterConverted = 1
lngColumnCounter = 1

Do While Not IsEmpty(wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter))

    Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)
    strKey = rngCurrent.Value ' Get the key value from the current cell'
    lngColumnCounter = 2

    'This next loop parses the deConverted values for each row'
    Do While Not IsEmpty(wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter))
        Set rngCurrent = wsOriginal.Cells(lngRowCounterOriginal, lngColumnCounter)

        'We're going to check to see if the current value'
        'is equal to NULL. If it is, we won't add it to'
        'the Converted Table.'
        If rngCurrent.Value = "NULL" Then
            'Skip it'
        Else
            'Add this item to the Converted sheet'
            wsConverted.Range("A" & lngRowCounterConverted).Value = strKey
            wsConverted.Range("B" & lngRowCounterConverted).Value = clnHeader(CStr(lngColumnCounter))
            wsConverted.Range("C" & lngRowCounterConverted).Value = rngCurrent.Value
            lngRowCounterConverted = lngRowCounterConverted + 1
        End If

        lngColumnCounter = lngColumnCounter + 1
    Loop
    lngRowCounterOriginal = lngRowCounterOriginal + 1
    lngColumnCounter = 1    'We reset the column counter here because we're on a new row'
Loop

End Sub

 

[Marcelo Branco]

Maybe this video can help
https://www.youtube.com/watch?v=xmqTN0X-AgY

M.

 

[rohit1409]

Solved in some other forum.. posting reply here..

Sub Convert_Data()
'Aug 29, 2016
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Sheets("Sheet1") '<< source sheet name, change as needed
Dim r As Long, c As Long, t As Long, x As Long
r = ws1.Range("A1").CurrentRegion.Rows.Count
c = ws1.Range("A1").CurrentRegion.Columns.Count
Application.ScreenUpdating = False
Set ws2 = Sheets.Add(before:=Sheets(1))
t = 1
For x = 2 To c
ws1.Range("A2").Resize(r - 1).Copy Cells(t, 1)
ws1.Cells(1, x).Copy Cells(t, 2).Resize(r - 1)
ws1.Cells(2, x).Resize(r - 1).Copy Cells(t, 3).Resize(r - 1)
t = ws2.Range("A1").CurrentRegion.Rows.Count + 1
Next
ActiveSheet.UsedRange.EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub