Create Multiple Rows based on Years

JNowell

New Member
Joined
Jun 15, 2015
Messages
11
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:

[TABLE="width: 881"]
<tbody>[TR]
[TD]P/N[/TD]
[TD]Make[/TD]
[TD]Mfg[/TD]
[TD]Model[/TD]
[TD]Year Span[/TD]
[TD]Fitment Years[/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="width: 881"]
<tbody>[TR]
[TD]881612[/TD]
[TD]Aprilia[/TD]
[TD]881965[/TD]
[TD]1000 RSV4 - (SACHS)[/TD]
[TD]10-12[/TD]
[TD]2010, 2011, 2012[/TD]
[/TR]
</tbody>[/TABLE]


THIS IS WHAT I NEED IT TO BE:
[TABLE="width: 494"]
<tbody>[TR]
[TD]P/N[/TD]
[TD]Make[/TD]
[TD]Mfg[/TD]
[TD]Model[/TD]
[TD]YearSpan[/TD]
[TD]Fitment Years[/TD]
[/TR]
[TR]
[TD]881612[/TD]
[TD]Aprilia[/TD]
[TD]881965[/TD]
[TD]1000 RSV4 - (SACHS)[/TD]
[TD]10-12[/TD]
[TD="align: right"]2010[/TD]
[/TR]
[TR]
[TD]881612[/TD]
[TD]Aprilia[/TD]
[TD]881965[/TD]
[TD]1000 RSV4 - (SACHS)[/TD]
[TD]10-12[/TD]
[TD="align: right"]2011[/TD]
[/TR]
[TR]
[TD]881612[/TD]
[TD]Aprilia[/TD]
[TD]881965[/TD]
[TD]1000 RSV4 - (SACHS)[/TD]
[TD]10-12[/TD]
[TD="align: right"]2012[/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
JNowell,

Assuming your data to be typically as below...
Excel Workbook
ABCDEF
1P/NMakeMfgModelYear SpanFitment Years
2881612Aprilia8819651000 RSV4 - (SACHS)10 to 122010, 2011, 2012
3881613Aprilia8819661001 RSV4 - (SACHS)10 to 122010, 2011, 2012
4881614Aprilia8819671002 RSV4 - (SACHS)10 to 122010
5881615Aprilia8819681003 RSV4 - (SACHS)10 to 122010, 2011
6881616Aprilia8819691004 RSV4 - (SACHS)10 to 122010, 2011, 2012
Sheet1


Then the following code should rearrange....

Code:
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.
 
Upvote 0
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

*ABCDEF
P/NMakeMfgModelYear SpanFitment Years
Aprilia1000 RSV4 - (SACHS)10 to 122010, 2011, 2012
Aprilia1001 RSV4 - (SACHS)10 to 122010, 2011, 2012
Aprilia1002 RSV4 - (SACHS)10 to 12
Aprilia1003 RSV4 - (SACHS)10 to 122010, 2011
Aprilia1004 RSV4 - (SACHS)10 to 122010, 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>
[TD="bgcolor: #cacaca, align: center"]1[/TD]

[TD="bgcolor: #cacaca, align: center"]2[/TD]
[TD="align: right"]881612[/TD]

[TD="align: right"]881965[/TD]

[TD="bgcolor: #cacaca, align: center"]3[/TD]
[TD="align: right"]881613[/TD]

[TD="align: right"]881966[/TD]

[TD="bgcolor: #cacaca, align: center"]4[/TD]
[TD="align: right"]881614[/TD]

[TD="align: right"]881967[/TD]

[TD="align: right"]2010[/TD]

[TD="bgcolor: #cacaca, align: center"]5[/TD]
[TD="align: right"]881615[/TD]

[TD="align: right"]881968[/TD]

[TD="bgcolor: #cacaca, align: center"]6[/TD]
[TD="align: right"]881616[/TD]

[TD="align: right"]881969[/TD]

</tbody>


Excel tables to the web >> Excel Jeanie HTML 4

Then the following code should rearrange....

Code:
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.
 
Upvote 0
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.....
Code:
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.
 
Last edited:
Upvote 0
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) ********

Code:
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
 
Last edited:
Upvote 0
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) ********

Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,402
Messages
6,171,906
Members
452,432
Latest member
TiffanyMcllwain

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top