Transpose based on variable length of items in rows , for a sheet of more than 1000 entries

Question

im very new to vba coding and trying to learn. I have a sheet of more than 1000 entries . Column A is Sr number, Column B has Names and Column C to Column V has items (20 columns max). Each name in Column B can buy multiple items (column C to Column V) and based on number of items bought, i want to insert rows and fill it up with items against name column.

1 | Mac | ball | eggs |

2 | Roy | net | fish | milk | shoes |

.

1000

output

Sr | Name | Items |

1    | Mac  | ball  |  

     | Mac  | eggs  |

2    |Roy   | net   | 

     |Roy   |fish   | 

     |Roy   |Milk   |

     |Roy   | shoes |

.

1000

Do a search for **unpivot**. Plenty of examples. Then rewrite your question to include the code you tried, and problems you run into. — Ron Rosenfeld, Sep 17 '21 at 19:23
Please provide enough code so others can better understand or reproduce the problem. — Community, Sep 27 '21 at 02:45

score 0 · Answer 1 · answered Sep 17 '21 at 20:17

Put the entries on Sheet 1, the list is created on Sheet 2

Option Explicit

Sub TransposeMacro()

    Dim ws1 As Worksheet, ws2 As Worksheet, ar As Variant, rng As Range
    Dim r As Long, c As Long, r2 As Long

    Set ws1 = ThisWorkbook.Sheets(1)
    Set ws2 = ThisWorkbook.Sheets(2)
    ' sheet 2 headers
    ws2.Range("A1:C1") = Array("Sr", "Name", "Items")
    r2 = 2

    Application.ScreenUpdating = False
    ar = ws1.UsedRange.Value2
    For r = 2 To UBound(ar)
        ws2.Cells(r2, 1) = ar(r, 1)
        For c = 3 To UBound(ar, 2)
            If Len(ar(r, c)) > 0 Then
                ws2.Cells(r2, 2) = ar(r, 2)
                ws2.Cells(r2, 3) = ar(r, c)
                r2 = r2 + 1
            End If
        Next
    Next
    Application.ScreenUpdating = True
    MsgBox "Done", vbInformation

End Sub

Transpose based on variable length of items in rows , for a sheet of more than 1000 entries

1 Answers1