Create Multiple Rows based on Years

[JNowell]

I have an Excel file that has the following columns. I need to have each Fitment Year listed as a single row. Is there a way to create a Macro that would look at the fitment years cell and then duplicate the row for each year? This is an ongoing macro that I will have to run each month against an Excel file that has several hundred lines that will expand exponentially once it is expanded for each year. I really need your help! I'm desperate.

THIS IS WHAT I HAVE:

P/N

Make

Mfg

Model

Year Span

Fitment Years

<tbody>
</tbody>

881612

Aprilia

881965

1000 RSV4 - (SACHS)

10-12

2010, 2011, 2012

<tbody>
</tbody>

THIS IS WHAT I NEED IT TO BE:

P/N	Make	Mfg	Model	YearSpan	Fitment Years
881612	Aprilia	881965	1000 RSV4 - (SACHS)	10-12	2010
881612	Aprilia	881965	1000 RSV4 - (SACHS)	10-12	2011
881612	Aprilia	881965	1000 RSV4 - (SACHS)	10-12	2012

<tbody>
</tbody>

 

[Snakehips]

JNowell,

Assuming your data to be typically as below...

Excel Workbook
	A	B	C	D	E	F
1	P/N	Make	Mfg	Model	Year Span	Fitment Years
2	881612	Aprilia	881965	1000 RSV4 - (SACHS)	10 to 12	2010, 2011, 2012
3	881613	Aprilia	881966	1001 RSV4 - (SACHS)	10 to 12	2010, 2011, 2012
4	881614	Aprilia	881967	1002 RSV4 - (SACHS)	10 to 12	2010
5	881615	Aprilia	881968	1003 RSV4 - (SACHS)	10 to 12	2010, 2011
6	881616	Aprilia	881969	1004 RSV4 - (SACHS)	10 to 12	2010, 2011, 2012
Sheet1

Then the following code should rearrange....

Sub Split_Data()
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
    Set Rng1 = Cells(r, "F")
    Arry = Split(Trim(Rng1), ", ")
    n = UBound(Arry)
        If n > 0 Then
            Set Rng2 = Range("A" & r & ":E" & r)
            Set Rng3 = Rng2.Resize(n, 5)
            Rng3.EntireRow.Insert
                For c = n To 1 Step -1
                    Rng2.Offset(-c, 0).Value = Rng2.Value
                Next c
                
                For c = n To 0 Step -1
                    Rng1.Offset(-c, 0).Value = Arry(n - c)
                Next c
        End If


Next r
Application.ScreenUpdating = True
End Sub

Currently, it tests every row in the list so to prevent it getting stupidly slow on a large data set it may need modifying according to how you are adding the new un-split data to the list.

Hope that helps some.

 

[JNowell]

Tony,
You are awesome. This does work well except it changed the E column to a date instead of it being text. I formatted the entire sheet as text and ran it again and it worked Perfect!
Would this convert all cells to TEXt be able to be added to the macro?

You're right about it being SLOW. I have over 300,000 rows in my original file. I ran it against only 190,000 rows and it has been running for over 10 minutes and is still going.
Any ideas on how it could run quicker?

Also, thanks for the tip of inserting a screen shot. I never thought of that.
Joanie

JNowell,

Assuming your data to be typically as below...Sheet1

*	A	B	C	D	E	F
1	P/N	Make	Mfg	Model	Year Span	Fitment Years
2	881612	Aprilia	881965	1000 RSV4 - (SACHS)	10 to 12	2010, 2011, 2012
3	881613	Aprilia	881966	1001 RSV4 - (SACHS)	10 to 12	2010, 2011, 2012
4	881614	Aprilia	881967	1002 RSV4 - (SACHS)	10 to 12	2010
5	881615	Aprilia	881968	1003 RSV4 - (SACHS)	10 to 12	2010, 2011
6	881616	Aprilia	881969	1004 RSV4 - (SACHS)	10 to 12	2010, 2011, 2012

<colgroup><col style="font-weight:bold; width:30px; "><col style="width:60px;"><col style="width:60px;"><col style="width:60px;"><col style="width:159px;"><col style="width:82px;"><col style="width:154px;"></colgroup><tbody>
</tbody>

Excel tables to the web >> Excel Jeanie HTML 4

Then the following code should rearrange....

Sub Split_Data()
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
    Set Rng1 = Cells(r, "F")
    Arry = Split(Trim(Rng1), ", ")
    n = UBound(Arry)
        If n > 0 Then
            Set Rng2 = Range("A" & r & ":E" & r)
            Set Rng3 = Rng2.Resize(n, 5)
            Rng3.EntireRow.Insert
                For c = n To 1 Step -1
                    Rng2.Offset(-c, 0).Value = Rng2.Value
                Next c
                
                For c = n To 0 Step -1
                    Rng1.Offset(-c, 0).Value = Arry(n - c)
                Next c
        End If


Next r
Application.ScreenUpdating = True
End Sub

Currently, it tests every row in the list so to prevent it getting stupidly slow on a large data set it may need modifying according to how you are adding the new un-split data to the list.

Hope that helps some.

 

[Snakehips]

Joanie,

This revised code, working with arrays, does 100,000 rows for me in about 45 seconds.......


Declare Option Base 1 at the TOP of the code module.

Then.....

Sub Split_Data2()


Dim FinArry() 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
lr = Cells(Rows.Count, "A").End(xlUp).Row


'Data into an array
DatArry = Range("A2:F" & lr)
rf = 0
'Manipulate within arrays
For r = LBound(DatArry, 1) To UBound(DatArry, 1)
    SplitArry = Split(Trim(DatArry(r, 6)), ", ")
    
    If UBound(SplitArry) < 0 Then
    lo = 999
    hi = 999
    Else
    lo = LBound(SplitArry)
    hi = UBound(SplitArry)
    End If
    For i = lo To hi
        rf = rf + 1
        ReDim Preserve FinArry(1 To 6, 1 To rf)
            For c = 1 To 5
                FinArry(c, rf) = DatArry(r, c)
            Next c
            If i < 999 Then FinArry(6, rf) = SplitArry(i)
        Next i
Next r
   
'Final Array data back to sheet
For fc = 1 To UBound(FinArry, 2)
    For fr = 1 To 6
        Cells(fc + 1, fr + 10) = FinArry(fr, fc)
    Next fr
Next fc
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
End Sub

As your data expands, are you running this code on previously split data + the new data or just the new data ?

Hope that helps.

 

[Snakehips]

Just realised that I left an offset of 10 in the above code so that it would put the new listing in columns K:P so that I did not overwrite my original data whilst testing.

To have it write to A:F use the below with the +10 offset removed from Cells(fc + 1, fr) ********

Sub Split_Data2()
Dim FinArry()
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
lr = Cells(Rows.Count, "A").End(xlUp).Row


'Data into an array
DatArry = Range("A2:F" & lr)
rf = 0
'Manipulate within arrays
For r = LBound(DatArry, 1) To UBound(DatArry, 1)
    SplitArry = Split(Trim(DatArry(r, 6)), ", ")
    
    If UBound(SplitArry) < 0 Then
    lo = 999
    hi = 999
    Else
    lo = LBound(SplitArry)
    hi = UBound(SplitArry)
    End If
    For i = lo To hi
        rf = rf + 1
        ReDim Preserve FinArry(1 To 6, 1 To rf)
            For c = 1 To 5
                FinArry(c, rf) = DatArry(r, c)
            Next c
            If i < 999 Then FinArry(6, rf) = SplitArry(i)
        Next i
Next r
   
'Final Array data back to sheet
For fc = 1 To UBound(FinArry, 2)
    For fr = 1 To 6
        Cells(fc + 1, fr) = FinArry(fr, fc)   '***********
    Next fr
Next fc
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
End Sub

 

[JNowell]

It works to breakout the year lines but it does not seem to be copying my columns of data G-P and bring that text down on the subsiquant lines.

file:///Users/Joan/Desktop/Screen%20Shot%202015-10-14%20at%205.10.49%20PM.png

I tried to past in a screen shot of the original file sitting under the broken out file.
Any ideas?
Joanie

Just realised that I left an offset of 10 in the above code so that it would put the new listing in columns K:P so that I did not overwrite my original data whilst testing.

To have it write to A:F use the below with the +10 offset removed from Cells(fc + 1, fr) ********

Sub Split_Data2()
Dim FinArry()
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
lr = Cells(Rows.Count, "A").End(xlUp).Row


'Data into an array
DatArry = Range("A2:F" & lr)
rf = 0
'Manipulate within arrays
For r = LBound(DatArry, 1) To UBound(DatArry, 1)
    SplitArry = Split(Trim(DatArry(r, 6)), ", ")
    
    If UBound(SplitArry) < 0 Then
    lo = 999
    hi = 999
    Else
    lo = LBound(SplitArry)
    hi = UBound(SplitArry)
    End If
    For i = lo To hi
        rf = rf + 1
        ReDim Preserve FinArry(1 To 6, 1 To rf)
            For c = 1 To 5
                FinArry(c, rf) = DatArry(r, c)
            Next c
            If i < 999 Then FinArry(6, rf) = SplitArry(i)
        Next i
Next r
   
'Final Array data back to sheet
For fc = 1 To UBound(FinArry, 2)
    For fr = 1 To 6
        Cells(fc + 1, fr) = FinArry(fr, fc)   '***********
    Next fr
Next fc
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Done"
End Sub