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?

score 0 · Accepted Answer · answered Sep 19 '13 at 00:00

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

Thanks for the response. Is there any setup needed to the file before running this? As is, running it doesn't even make the spreadsheet twitch. Hm... — Dogulas, Sep 19 '13 at 11:50
It's looking at sheet1 for the data and will reformat it on sheet2. As long as your data matches your example it should work ok. — Tim Williams, Sep 19 '13 at 14:48
With a few tweaks to declare sheets I got this running and it works swimmingly. Thank you very much! — Dogulas, Sep 19 '13 at 15:40

In Excel VBA, create new rows based on column data

1 Answers1

Linked