Manipulate and transpose data to another sheet via a Macro

[Phil_MacRae]

I wish to copy data to another sheet using a macro. Sounds simple however
I currently have headings in my Columns i.e Alfa, Beta, Charlie, Delta – displayed as shown below
Alfa Beta Charlie Delta
Info one 3 1 3 2
Info two 1 1 2 1

I wish to copy this data to ‘sheet 2’ but I need the formula/macro to transpose the text “Alfa” the actual number shown under the row heading 'info 1' ...... then beta etc etc. Once this is done ...... I want it to loop to the next heading 'info two' and do the same under the information transposed from 'info one'– I have tried to show this below: - There are multiple rows I need to do this but hopefully once I uderstand how to do this on 2 rows it will be straight forward

Info one Alfa //3 times
Info one Alfa
Info one Alfa
Info one Beta //1 time
Info one Charlie //3times
Info one Charlie
Info one Charlie
Info one Delta //2 times
Info one Delta
//hopefully no space
Info two Alfa
Info two Beta
Info two Charlie
Info two Charlie
Info two Delta


Hope this makes sense - Thanks in advance

[mike7952]

Might be better to upload a wb as an example.

[Phil_MacRae]

Book10.xlsx
Work book attached

[mike7952]

Try this. Im assuming columns C thru J on sheet 2 will be empty.

Option Explicit
Sub abc()
 Dim a, b, i As Long, ii As Long, iii As Long, n As Long
 Dim aDesc
 
 With Worksheets("sheet1")
    aDesc = .Range("b1:g1")
    a = .Range("a6", .Cells(Rows.Count, "g").End(xlUp))
 End With
 
 ReDim b(1 To Rows.Count, 1 To 10)
 
 For i = 1 To UBound(a)
    For ii = 1 To UBound(aDesc, 2)
        If a(i, ii + 1) > 0 Then
            For iii = 1 To a(i, ii + 1)
                n = n + 1
                b(n, 1) = a(i, 1)
                b(n, 10) = aDesc(1, ii)
            Next
        End If
    Next
 Next
 With Worksheets("sheet2")
    .Cells(6, "b").Resize(n, 10) = b
 End With
End Sub

[Phil_MacRae]

Excellent - thankyou very much - trying to understand the Macro now.

[mike7952]

Maybe this will be easier to understand

Option Explicit
Sub abc()
 Dim b, iRow As Long, iCol As Long, iLooper As Long, n As Long

 ReDim b(1 To Rows.Count, 1 To 10)
 With Worksheets("sheet1")
    For iRow = 6 To .Cells(Rows.Count, "a").End(xlUp).Row
        For iCol = 2 To 6
            With .Cells(iRow, iCol)
                If .Value > 0 Then
                    For iLooper = 1 To .Value
                        n = n + 1
                        With Worksheets("sheet1")
                            b(n, 1) = .Cells(iRow, 1)
                            b(n, 10) = .Cells(1, iCol)
                        End With
                    Next
                End If
            End With
        Next
    Next
 End With
 With Worksheets("sheet2")
    .Cells(6, "b").Resize(n, 10) = b
 End With
End Sub