Copy and insert a new row n times changing one cell value

[claple]

Input
col1 | col2 | col3
we | love | cats,dogs
fish | hate | cats
we | eat | fish,cow,rabbit

output
col1 | col2 | col3
we | love | cats
we | love | dogs
fish | hate | cats
we | eat | fish
we | eat | cow
we | eat | rabbit

any idea for a macro that can accomplish this?

 

[rpaulson]

try this code on a copy of you file:

Sub do_it()

Dim MyArray() As String

wr = 1

For r = 1 To 3 'adjust length as needed

a = Cells(r, "A")
b = Cells(r, "B")

MyArray() = Split(Cells(r, "C"), ",")
For i = LBound(MyArray) To UBound(MyArray)

 Cells(wr, "E") = a
 Cells(wr, "F") = b
 Cells(wr, "G") = MyArray(i)
 
wr = wr + 1
Next i
Next r

End Sub

hth,

Ross

 

[tonyyy]

claple,

Welcome to the Board.

Another approach...

Sub ResizeRows()
Application.ScreenUpdating = False
Dim i As Long, j As Long, kount As Long
Dim arr() As String
For i = Cells(Rows.Count, "C").End(xlUp).Row To 2 Step -1
    arr = Split(Cells(i, 3), ",")
    kount = UBound(arr)
    If kount > 0 Then
        With Rows(i)
            .Copy
            .Offset(1, 0).Resize(kount, 1).EntireRow.Insert
        End With
        For j = LBound(arr) To UBound(arr)
            Cells(j + i, 3) = arr(j)
        Next j
    End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Assumes headers in Row 1.

Cheers,

tonyyy

p.s. In future, please see my signature for instructions on how to copy/paste your excel data to the Board.

 

[hiker95]

claple,

Welcome to the MrExcel forum.

Here is another macro for you to consider.

I assume that there are no titles in row 1.

Sample raw data in the active worksheet:

Excel 2007
	A	B	C
1	we	love	cats,dogs
2	fish	hate	cats
3	we	eat	fish,cow,rabbit
4
5
6
7
Sheet1

And, after the macro:

Excel 2007
	A	B	C
1	we	love	cats
2	we	love	dogs
3	fish	hate	cats
4	we	eat	fish
5	we	eat	cow
6	we	eat	rabbit
7
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorgData()
' hiker95, 03/28/2017, ME998085
Dim r As Long, lr As Long, s
Application.ScreenUpdating = False
With ActiveSheet
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  For r = lr To 1 Step -1
    If InStr(.Cells(r, 3), ",") Then
      s = Split(Trim(.Cells(r, 3)), ",")
      .Rows(r + 1).Resize(UBound(s)).Insert
      .Cells(r + 1, 1).Resize(UBound(s)) = .Cells(r, 1)
      .Cells(r + 1, 2).Resize(UBound(s)) = .Cells(r, 2)
      .Cells(r, 3).Resize(UBound(s) + 1) = Application.Transpose(s)
    End If
  Next r
  .Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgData macro.

 

[claple]

tonyyy....thank you so much for the fast and accurate solution....work like a charm!

claple,

Welcome to the Board.

Another approach...

Sub ResizeRows()
Application.ScreenUpdating = False
Dim i As Long, j As Long, kount As Long
Dim arr() As String
For i = Cells(Rows.Count, "C").End(xlUp).Row To 2 Step -1
    arr = Split(Cells(i, 3), ",")
    kount = UBound(arr)
    If kount > 0 Then
        With Rows(i)
            .Copy
            .Offset(1, 0).Resize(kount, 1).EntireRow.Insert
        End With
        For j = LBound(arr) To UBound(arr)
            Cells(j + i, 3) = arr(j)
        Next j
    End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Assumes headers in Row 1.

Cheers,

tonyyy

p.s. In future, please see my signature for instructions on how to copy/paste your excel data to the Board.

 

[tonyyy]

You're welcome, claple. Glad it worked out...