Macro help - copy row, split data into multiple rows to create multiple entires for each row

[michelleW888]

Hoping someone can help with this complicated Macros. I need to Macro help - copy row, split data into multiple rows to create multiple entires for each row.

I need to create a new row that copies model, type and size data and splits color code and quantity into separate rows.

This is the data I currently have:

Model

​

Type Color Code Size Qty
A half C1,C2,C4,C6,C7 53-29 4,6,7,3,8
B circle C111,C146 54-26 10,5
C whole C1,C7 54-30 6,6



These rows would be replaced by the following rows:

Model Type Color Code Size Qty
A half C1 53-29 4
A half C2 53-29 6
A half C4 53-29 7
A half C6 53-29 3
A half C7 53-29 8
B circle C111 54-26 10
B circle C146 54-26 5
C whole C1 54-30 6
C whole C7 54-30 6

 

[michelleW888]

updating with aligned excel columns:

these are the columns I am working with:

Excel Workbook
	A	B	C	D	E
3	A	half	C1,C2,C4,C6,C7	53-29	4,6,7,3,8
4	B	circle	C111,C146	54-26	10,5
5	C	whole	C1,C7	54-30	6,6
Sheet1

These rows would be replaced by the following rows:

Excel Workbook
	A	B	C	D	E
11	A	half	C1	53-29	4
12	A	half	C2	53-29	6
13	A	half	C4	53-29	7
14	A	half	C6	53-29	3
15	A	half	C7	53-29	8
16	B	circle	C111	54-26	10
17	B	circle	C146	54-17-140,54-26	5
18	C	whole	C1	54-30	6
19	C	whole	C7	54-30	6
Sheet1

 

[VoG]

I don't know how you arrive at the result in D17 but try this with Sheet1 selected. Results in Sheet2.

Sub Michelle()
Dim LR As Long, i As Long, j As Integer, X, Y
LR = Range("A" & Rows.Count).End(xlUp).Row
For i = 3 To LR
    X = Split(Range("C" & i).Value, ",")
    Y = Split(Range("E" & i).Value, ",")
    For j = LBound(X) To UBound(X)
        Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1).Value = Range("A" & i).Value
        Sheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Offset(1).Value = Range("B" & i).Value
        Sheets("Sheet2").Range("C" & Rows.Count).End(xlUp).Offset(1).Value = X(j)
        Sheets("Sheet2").Range("D" & Rows.Count).End(xlUp).Offset(1).Value = Range("D" & i).Value
        Sheets("Sheet2").Range("E" & Rows.Count).End(xlUp).Offset(1).Value = Y(j)
    Next j
Next i
End Sub

 

[michelleW888]

This is Amazing! Thank you so much for your help!