If cells in a column match then combine all values in another column

[clent724]

I am not sure if there's even a formula for this to work. I attached images to show what my data looks like now and what I would like as the end result. The file I am working on actually has 9800 rows so this would be such a huge relief to have this work.

Basically, if part numbers in column A match then I need to combine the values in column E with a ; in between them.

Then the remaining data in columns 3, 4 and 5 can be removed since they are the same as row 2. This is just an example. The file I will be working on actually had around 9800 rows with many different part numbers.

I tried doing my best to explain this and feel that the pictures will help. I'm very sorry if I'm not clear. Thanks in advance for any help!

 

[clent724]

I see what you mean, that could be difficult to handle. It could be shortened as much as Year, Make, Model, Part instead of Vehicle Year, Vehicle Make, etc. Just shortening it to Y would not be used friendly because in the filter panel of our website it would just display Y to the customer.

The 2004 one you referred to would actually fit that vehicle so in a case where a year is missing I'm not too concerned with because I'd say it is most likely human error the reason it wasn't entered. But for the next one you referred to with the Toyota Sienna, it would show both hear ranges when imported to our site. It isn't too big of a deal I don't think because the customer will choose their year. Ideally I really wanted the years separated how they were but it is just never going to work I don't think even with shortening down to Year, Make, Model, Part.

If anyone can figure this out though it's you. I am so impressed with everything I've learned so far.

 

[Peter_SSs]

Thought of a possible way to proceed, but then noticed that there are lines like the middle 4 here that thwarted that idea because they had no Year, Make or Model.
Are they relevant? How should lines like this be treated?

Excel Workbook
	L
361	Vehicle Year=2011-2012;Vehicle Make=Toyota;Vehicle Model=Highlander;Part Type=Vinyl Protection Film
362	Part Type=Headlight Guard
363	Part Type=Vinyl Protection Film
364	Part Type=Vinyl Protection Film
365	Part Type=Vinyl Protection Film
366	Vehicle Year=2011-2012;Vehicle Make=Chevrolet;Vehicle Model=Cruze;Part Type=Vinyl Protection Film
Husky before code

 

[clent724]

Yes, they are needed. They can be shortened to just "Part=Vinyl Protection Film". Parts like that are universal and will fit any vehicle that is why no year, make or model is specified.

 

[Peter_SSs]

Yes, they are needed. They can be shortened to just "Part=Vinyl Protection Film". Parts like that are universal and will fit any vehicle that is why no year, make or model is specified.

Does every row in the sheet have 1 section like those or 4 sections like the other rows in that sample, or might some row have 2 or 3 (or 5,6,7 ..) sections?

 

[clent724]

Most have 4 sections but some may have 1 or 2. It varies.

 

[Peter_SSs]

I have a further idea but not sure when I will be able to test it sufficiently & post.

 

[Peter_SSs]

Give this a try.

Sub clent724_Rearrange_v7()
  Dim a, b, c, d, yr, ky, yrbits
  Dim i As Long, j As Long, k As Long, lr As Long, x As Long, sy As Long
  Dim dmmp As Object, dy As Object, dspec As Object, AL As Object
  Dim s As String, smmp As String, sspec As String, mmp As String

  Const ProductCol As Long = 2      '<- Column B
  Const ColToCombine As Long = 12   '<- Column L
  
  Set dmmp = CreateObject("Scripting.Dictionary")
  dmmp.CompareMode = 1
  Set dy = CreateObject("Scripting.Dictionary")
  Set dspec = CreateObject("Scripting.Dictionary")
  dspec.CompareMode = 1
  Set AL = CreateObject("System.Collections.ArrayList")
  Application.ScreenUpdating = False
  With ActiveSheet
    lr = .Cells(.Rows.Count, ProductCol).End(xlUp).Row
    a = .Cells(1, ProductCol).Resize(lr + 1).Value
    b = .Cells(1, ColToCombine).Resize(lr).Value
    ReDim c(1 To lr, 1 To 1) As String
    ReDim d(1 To lr, 1 To 1)
    For i = 2 To lr
      s = Replace(Replace(b(i, 1), "Vehicle ", ""), " Type", "")
      If Len(s) > 0 Then
        If Left(LCase(s), 5) = "year=" Then
          mmp = Mid(s, InStr(1, s, ";"))
          dmmp(mmp) = dmmp(mmp) & Mid(Left(s, InStr(1, s, ";") - 1), 5)
        Else
          dspec(s) = 1
        End If
        If a(i, 1) <> a(i + 1, 1) Then
          k = k + 1
          d(i, 1) = k
          If dmmp.Count > 0 Then
            For Each ky In dmmp.Keys
              dy.RemoveAll
              For Each yr In Split(Mid(dmmp(ky), 2), "=")
                yrbits = Split(yr, "-")
                For j = yrbits(0) To yrbits(UBound(yrbits))
                  dy(j) = 1
                Next j
              Next yr
              AL.Clear
              For Each yr In dy.Keys
                AL.Add yr
              Next yr
              AL.Sort
              AL.Add 3000
              s = vbNullString
              j = 0
              Do Until AL(j) = 3000
                sy = AL(j)
                Do While AL(j + x + 1) = sy + x + 1
                  x = x + 1
                Loop
                s = s & "," & sy
                If x > 0 Then s = s & "-" & sy + x
                j = j + x + 1
                x = 0
              Loop
              smmp = smmp & vbLf & "Year=" & Mid(s, 2) & ky
            Next ky
            c(k, 1) = smmp
            smmp = vbNullString
            dmmp.RemoveAll
          End If
          If dspec.Count > 0 Then
            sspec = vbLf & Join(dspec.Keys, vbLf)
            dspec.RemoveAll
          End If
          c(k, 1) = Mid(c(k, 1) & sspec, 2)
          sspec = vbNullString
        End If
      End If
    Next i
    With .Cells(2, ColToCombine).Resize(lr)
      .WrapText = True
      .Value = d
      .Parent.UsedRange.Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
      On Error Resume Next
      .SpecialCells(xlBlanks).EntireRow.Delete
      On Error GoTo 0
      .Resize(k).Value = c
      .Columns.AutoFit
      .Rows.AutoFit
    End With
  End With
  Application.ScreenUpdating = True
End Sub