Help to roll up rows for year range

[rebubula]

Hi-

I posted this a while back, and am looking for a way to extend the column range, but keep running into an error.

I am looking for a way to roll up years into ranges if all other fields are the same. For example:

SKU Start Year End Year Make Model Sub Model
123123 1995 1995 Ford F150 King Ranch
123123 1996 1996 Ford F150 King Ranch
123123 1997 1997 Ford F150 King Ranch
123123 1996 1996 Ford F150
123123 1997 1997 Ford F150
123123 1998 1998 Ford F150

Should become:
SKU Start Year End Year Make Model Sub Model
123123 1995 1997 Ford F150 King Ranch
123123 1996 1998 Ford F150

Thanks in advance!

Here is the code that I am currently using, but it is deleting any information beyond the 7th column:

Sub RollUpYear()

Dim LastRow As Long
Dim LastColumn As Long
Dim i As Long

Application.ScreenUpdating = False

With ActiveSheet.UsedRange
LastRow = .Rows.Count + .Rows(1).Row - 1
LastColumn = .Columns.Count + .Columns(1).Column - 1
End With

Cells(1, LastColumn + 1).Value = "Concatenated Values"

Range(Cells(2, LastColumn + 1), Cells(LastRow, LastColumn + 1)).FormulaR1C1 = "=RC1&""#""&RC4&""#""&RC5&""#""&RC6&""#""&RC7"

With Range(Cells(1, 1), Cells(LastRow, LastColumn + 1))
.Sort key1:=Cells(1, LastColumn + 1), order1:=xlAscending, _
key2:=Cells(1, 2), order2:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With

For i = LastRow To 2 Step -1
If Cells(i, LastColumn + 1) = Cells(i - 1, LastColumn + 1) Then
If Cells(i, "B").Value - 1 = Cells(i - 1, "C").Value Then
Cells(i - 1, "C").Value = Cells(i, "C").Value
Rows(i).Delete
End If
End If
Next i

Cells(1, LastColumn + 1).EntireColumn.Delete

Application.ScreenUpdating = True

MsgBox "Completed...", vbInformation

End Sub

 

[MickG]

Try this:-
Results start "H1".
NB:- Where there are Blank cells in your range of data the Code Returns "-" to the Results, is that OK.

[COLOR=navy]Sub[/COLOR] MG23Sep00
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] nRng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]Dim[/COLOR] Marker
[COLOR=navy]Dim[/COLOR] Q
    [COLOR=navy]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
     [COLOR=navy]Set[/COLOR] nRng = Rng.Resize(, 7).SpecialCells(xlCellTypeBlanks)
         nRng.Value = "-"
        [COLOR=navy]With[/COLOR] CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] Rng
 
    Marker = Dn & Dn(, 4) & Dn(, 5) & Dn(, 6) & Dn(, 7)
        [COLOR=navy]If[/COLOR] Not .Exists(Marker) [COLOR=navy]Then[/COLOR]
           .Add Marker, Array(Dn, Dn(, 2), Dn(, 3), Dn(, 4), Dn(, 5), Dn(, 6), Dn(, 7))
        [COLOR=navy]Else[/COLOR]
            Q = .Item(Marker)
             Q(2) = Dn(, 3)
            .Item(Marker) = Q
        [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
Range("H1").Resize(.Count, 7) = Application.Transpose(Application.Transpose(.Items))
[COLOR=navy]End[/COLOR] With
nRng.Value = ""
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick

 

[MickG]

Slightly Better !!!

[COLOR="Navy"]Sub[/COLOR] MG23Sep57
[COLOR="Navy"]Dim[/COLOR] Rng     [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn      [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng    [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Marker  [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Q
    [COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
     [COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] [COLOR="Navy"]Resume[/COLOR] [COLOR="Navy"]Next[/COLOR]
     [COLOR="Navy"]Set[/COLOR] nRng = Rng.Resize(, 7).SpecialCells(xlCellTypeBlanks)
       nRng.Value = "-"
         [COLOR="Navy"]On[/COLOR] [COLOR="Navy"]Error[/COLOR] GoTo 0
        [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
            .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    
    Marker = Dn & Dn(, 4) & Dn(, 5) & Dn(, 6) & Dn(, 7)
        [COLOR="Navy"]If[/COLOR] Not .Exists(Marker) [COLOR="Navy"]Then[/COLOR]
           .Add Marker, Array(Dn, Dn(, 2), Dn(, 3), Dn(, 4), Dn(, 5), Dn(, 6), Dn(, 7))
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Marker)
              Q(2) = Dn(, 3)
            .Item(Marker) = Q
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
Range("H1").Resize(.Count, 7) = Application.Transpose(Application.Transpose(.Items))
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.Value = ""
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick