In Excel VBA, create new rows based on column data

Question

For the record, I am an untrained, recorded-macro-only-VBA-user. I try to pick up bits and pieces here and there, but I'm still a total noob. Please point me in the right direction!

On each row, part number (column E) should be associated with a source and address (column G and H) and description (column I). I say "should be", but in actuality, rather than one source/address combo for each part number, in many files there are up to fifteen different source/address combos on some lines, and the source/address combos are listed in adjacent columns J/K, L/M, N/O, etc., which pushes the description column over to the right.

I need to find a VB method for duplicating rows as many times as there are source/address combos, and stripping out all but one combo per row. Here's an example:

   A   B   C   D  Part#  F  Source1  Address1  Source2  Address2   Description
1  x   x   x   x  Part1  x  (S1)     (A1)                          Nut
2  x   x   x   x  Part2  x  (S1)     (A1)      (S2)     (A2)       Bolt

Row 2 has two source/address combos and needs to be duplicated with only one combo on each row, like so:

   A   B   C   D  Part#  F  Source   Address  Description
1  x   x   x   x  Part1  x  (S1)     (A1)     Nut
2  x   x   x   x  Part2  x  (S1)     (A1)     Bolt
3  x   x   x   x  Part2  x  (S2)     (A2)     Bolt

In another file I might have up to fifteen different source/address combos on any given row, which would then need to be duplicated fifteen times.

Is this making sense? In my head I'm hearing VBA functions I've never used like loop, do-while, do-until, etc. but I don't know enough syntax to begin implementing anything. Advice?

Answer 1

Sub Test()

Dim rw As Range, rwDest As Range, cellSrc As Range
Dim colDesc As Long, f As Range

    colDesc = 0
    'see if we can find the "description" column header
    Set f = Sheet1.Rows(1).Find(what:="Description", LookIn:=xlValues, lookat:=xlWhole)
    If Not f Is Nothing Then colDesc = f.Column

    Set rw = Sheet1.Rows(2)
    Do While Len(rw.Cells(, "E").Value) > 0
        Set cellSrc = rw.Cells(, "G")
        Do While Len(cellSrc.Value) > 0 And _
                 UCase(Sheet1.Rows(1).Cells(cellSrc.Column).Value) Like "*SOURCE*"
            Set rwDest = Sheet2.Cells(Rows.Count, "E").End(xlUp). _
                         Offset(1, 0).EntireRow
            rw.Cells(1).Resize(1, 6).Copy rwDest.Cells(1)
            cellSrc.Resize(1, 2).Copy rwDest.Cells(7)
            If colDesc > 0 Then rw.Cells(colDesc).Copy rwDest.Cells(9)

            Set cellSrc = cellSrc.Offset(0, 2)
        Loop
        Set rw = rw.Offset(1, 0)
    Loop

End Sub