Grouping rows based on partial match

Sub test()
Dim flag As Range, rng As Range, rng2 As Range, rng3 As Range
Dim i As Long, j As Long, k As Long, a, b As String, c As Long
Dim dic As Object, dic2 As Object
Set flag = Range("D2:D" & Cells(Rows.Count, 1).End(xlUp).Row)
Set dic = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
ReDim a(1 To flag.Count, 1): i = 1: k = 0
With dic
    .CompareMode = 1
    For Each rng In flag
        If rng.Value = "" Then
            a(i, 1) = rng.Offset(, -3) & ", " & rng.Offset(, -2) & vbCrLf & rng.Offset(, -1)
            i = i + 1
        End If
    Next rng
            For Each rng2 In flag
                If rng2.Value <> "" Then
                    If Not .exists(rng2.Value) Then
                        .Item(rng2.Value) = Empty
                        j = Application.WorksheetFunction.CountIf(flag, rng2.Value)
                        For Each rng3 In flag
                            If rng3.Value = rng2.Value Then
                                If Not dic2.exists(rng3.Offset(, -3).Value) Then
                                    dic2.Item(rng3.Offset(, -3).Value) = Empty
                                    a(i, 1) = a(i, 1) & vbCrLf & rng3.Offset(, -3) & ", " & rng3.Offset(, -2)
                                    k = k + 1
                                Else
                                   
                                    b = Split(a(i, 1), vbCrLf)(1)
                                    On Error Resume Next
                                    c = Application.WorksheetFunction.FindB(", ", b)
                                    If Err.Number = 0 Then
                                        a(i, 1) = Replace(a(i, 1), rng3.Offset(, -3).Value & ", ", rng3.Offset(, -3) & vbCrLf & rng3.Offset(, -2) & ", ")
                                    Else
                                        a(i, 1) = Replace(a(i, 1), rng3.Offset(, -3).Value & vbCrLf, rng3.Offset(, -3) & vbCrLf & rng3.Offset(, -2) & ", ")
                                    End If
                                    Err.Clear
                                    k = k + 1
                                    On Error GoTo 0
                                End If
                            End If
                            If k = j Then a(i, 1) = a(i, 1) & vbCrLf & rng3.Offset(, -1).Value: a(i, 1) = Right(a(i, 1), Len(a(i, 1)) - 2): Exit For
                        Next rng3
                        i = i + 1
                        dic2.RemoveAll: k = 0
                    End If
                End If
            Next rng2
End With
Set dic = Nothing
Set dic2 = Nothing
Sheets("Sheet2").Cells(1, 1).Resize(UBound(a), 2).Value = a
End Sub