CODEWITHSUNDEEP
excelvba
Jnowell
Jnowell

Reputation: 31

Copy or duplicate rows of data based upon cell value

I'm attempting to automate Excel in a way that will save me countless hours of tedious data entry. Here's my problem.

We have motorcycle parts that can fit on many different year model vehicles. The file I am working with has a list of the years in a cell. These years may or may not be consecutive. They are separated by a ",". I need a way to look at how many years are listed and duplicate the row of data that number of times.

I also need it to give only a single year for each of those rows. In the examples below the final column is FITMENT YEARS; As you can see it has 3 different years each separated by a comma. In this instance it is only 3 years it could be 10 different years or it could be just a single year.

THIS IS A SINGLE ROW OF WHAT I HAVE:

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

THIS IS HOW I NEED IT TO BE LISTED:

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

I really need someone's help. I'm lost on how to proceed. Thanks

Upvotes: 3

Views: 1136

Answers (2)

Josh Fierro
Josh Fierro

Reputation: 140

If your data exists in columns A:D, your original list is on Sheet1, and you want to create the new list on Sheet2, then the following vba will do what you need with a double loop. Change up "Sheet1" and "Sheet2" to suit your actual needs. Remember to format column C on sheet 2 as text or excel will automatically turn that data into a date...

Sub CreateYearList()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("Sheet2").Range("A1:D1").Value = Sheets("Sheet1").Range("A1:D1").Value
    Dim CmCt As Integer
    Dim NRwCt As Integer
    Dim ORwCt As Integer
    Dim LArray() As String
    Dim Yr As String
    ORwCt = WorksheetFunction.CountA(Sheets("Sheet1").Range("A:A"))
    For i = 2 To ORwCt
        LArray = Split(Sheets("Sheet1").Range("D" & i).Value, ",")
        CmCt = Len(Sheets("Sheet1").Range("D" & i).Value) - Len(Replace(Sheets("Sheet1").Range("D" & i).Value, ",", ""))
        NRwCt = WorksheetFunction.CountA(Sheets("Sheet2").Range("A:A"))
        For n = 1 To CmCt + 1
            Yr = LArray(n - 1)
            Sheets("Sheet2").Range("A" & NRwCt + n & ":C" & NRwCt + n).Value = Sheets("Sheet1").Range("A" & i & ":C" & i).Value
            Sheets("Sheet2").Range("D" & NRwCt + n).Value = Yr
        Next n
    Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

For additional fields, you can just change the the lines in the n loop to include whatever other fields are in your range. If they wrap around your Fitment Years column, then you can add an additional copy of the 2nd line in that loop and change it to include whatever range is beyond that column.

For example, let's say your Fitment Years column is actually column in column F and the additional fields go out to column Z. In that case you would need to change the 2nd line in the loop to go up to the column before Fitment Years (E), and add a copy of the 2nd line that looks at the column after Fitment Years (G) and goes all the way to Z. You would use these lines instead:

        Sheets("Sheet2").Range("A" & NRwCt + n & ":E" & NRwCt + n).Value = Sheets("Sheet1").Range("A" & i & ":E" & i).Value
        Sheets("Sheet2").Range("F" & NRwCt + n).Value = Yr
        Sheets("Sheet2").Range("G" & NRwCt + n & ":Z" & NRwCt + n).Value = Sheets("Sheet1").Range("G" & i & ":Z" & i).Value

Upvotes: 0

Excel Hero
Excel Hero

Reputation: 14764

Try this.

Place the following routine into a standard code module and run it.

IMPORTANT: this does an in-place replacement of your data, so make sure you have a copy before running this.

Sub Jnowell()
    Dim c&, n&, v, y
    With [a2]
        c = 1
        Do
            If Len(.Item(c)) Then
                y = Split(.Item(c, 4), ", ")
                If UBound(y) Then
                    .Item(c)(2).Resize(UBound(y), 4).Insert xlDown
                    v = .Item(c).Resize(, 4)
                    .Item(c, 4) = y(0)
                    For n = 1 To UBound(y)
                        .Item(c)(n + 1).Resize(, 4) = v
                        .Item(c, 4)(n + 1) = Left$(y(0), Len(y(0)) - 4) & y(n)
                    Next
                End If
            Else
                Exit Do
            End If
            c = c + 1
        Loop
    End With
End Sub

Note: this routine assumes your data are in columns A, B, C, and D of the currently active sheet.

Upvotes: 2

Related Questions