Have any other ways to combine strings of same item? - excel

Question

I would like to ask how to shorten the code below? Have any other ways to achieve the same result?
Option Explicit
Sub test()
Dim i As Integer
Dim nRow As Integer: nRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To nRow
If Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) And Cells(i + 3, 1) = Cells(i + 4, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2) & "/" & Cells(i + 4, 2)
Rows(i + 1 & ":" & i + 4).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) And Cells(i + 2, 1) = Cells(i + 3, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2) & "/" & Cells(i + 3, 2)
Rows(i + 1 & ":" & i + 3).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) And Cells(i + 1, 1) = Cells(i + 2, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2) & "/" & Cells(i + 2, 2)
Rows(i + 1 & ":" & i + 2).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) <> "" And Cells(i, 1) = Cells(i + 1, 1) Then
Cells(i, 2) = Cells(i, 2) & "/" & Cells(i + 1, 2)
Rows(i + 1 & ":" & i + 1).Delete Shift:=xlShiftUp
ElseIf Cells(i, 1) = "" Then
Exit For
End If
Next i
End Sub
Thank you!

Answer 1

Here's Dictionary based approach which should work for you.
Public Sub RearrangeData()
Dim objDic As Object
Dim varRng
Dim i As Long
Set objDic = CreateObject("Scripting.Dictionary")
objDic.CompareMode = vbTextCompare '\\ change this if you need it case sensitive
varRng = Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
For i = LBound(varRng) To UBound(varRng)
If objDic.Exists(varRng(i, 1)) Then
objDic.Item(varRng(i, 1)) = objDic.Item(varRng(i, 1)) & "/" & varRng(i, 2)
Else
objDic.Add varRng(i, 1), varRng(i, 2)
End If
Next i
Range("A2:B" & Range("A" & Rows.Count).End(xlUp).Row).ClearContents
Range("A2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Keys)
Range("B2").Resize(objDic.Count, 1).Value = Application.Transpose(objDic.Items)
Set objDic = Nothing
End Sub

Answer 2

here's another dictionary approach (no reference adding required)
Sub strings()
Dim data As Variant, key As Variant
Dim i As Long
data = Range("B2", Cells(Rows.Count, 1).End(xlUp)).Value
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(data)
.Item(data(i, 1)) = .Item(data(i, 1)) & "/" & data(i, 2)
Next
Range("A1").CurrentRegion.Resize(Range("A1").CurrentRegion.Rows.Count - 1).Offset(1).ClearContents
i = 1
For Each key In .Keys
i = i + 1
Cells(i, 1) = key
Cells(i, 2) = Mid(.Item(key), 2)
Next
End With
End Sub
BTW, should you ever need to combine strings from more columns, you could use
Option Explicit
Sub strings()
Dim data As Variant, key As Variant
Dim i As Long, iCol As Long
With Range("A1").CurrentRegion
With .Resize(.Rows.Count - 1).Offset(1)
data = .Value
.ClearContents
End With
End With
With CreateObject("Scripting.Dictionary")
For iCol = 2 To UBound(data, 2)
For i = 1 To UBound(data)
.Item(data(i, 1)) = Trim(.Item(data(i, 1)) & " " & data(i, iCol))
Next
Range("A2").Resize(.Count) = Application.Transpose(.Keys)
Range("A2").Resize(.Count).Offset(, iCol - 1) = Application.Transpose(.Items)
.RemoveAll
Next
End With
Range("a1").CurrentRegion.Replace what:=" ", replacement:="/", lookat:=xlPart
End Sub