Sub ertert22_2()
Dim x, i&, j&, r As Range, adr As String, sp: Application.ScreenUpdating = False
  Sheets("Лист1").Activate
  x = Range("C1:D" & Cells(Rows.Count, 3).End(xlUp).Row).Value
With Range("A1", Cells(Rows.Count, 1).End(xlUp))
      For i = 1 To UBound(x)
          Set r = .Find(x(i, 1))
          If Not r Is Nothing Then
              adr = r.Address
              Do
                  x(i, 2) = x(i, 2) & "~" & r
                  Set r = .FindNext(r)
              Loop While r.Address <> adr
          End If
      Next i
End With
With Sheets("Лист4")
      For i = 1 To UBound(x)
          With .Cells(Rows.Count, 1).End(xlUp)(3)
              .Value = x(i, 1)
              .Resize(, 22).Borders.Weight = xlThin
              [b]If InStr(x(i, 2), "~") Then[/b]
                  sp = Split(Mid(x(i, 2), 2), "~")
                  For j = 0 To UBound(sp)
                      sp(j) = x(i, 1) & Split(sp(j), x(i, 1))(1)
                  Next j
                  With .Cells(2).Resize(UBound(sp) + 1)
                      .Value = Application.Transpose(sp)
                      .Resize(UBound(sp) + 2, 22).Borders.LineStyle = xlContinuous
                      .Resize(UBound(sp) + 2, 22).Borders.Item(xlInsideHorizontal).LineStyle = xlLineStyleNone
                  End With
                  .Item(1, 4).FormulaR1C1 = "=SUM(R[1]C:R[" & UBound(sp) + 1 & "]C)"
              End If
          End With
      Next i
      .Activate
End With: Application.ScreenUpdating = True
End Sub