Sub d()
Dim d As Object, arr(1 To 4), d1 As New Scripting.Dictionary
Set d = CreateObject("Scripting.dictionary")
    m = Range("A2").CurrentRegion.Value
    Range(Selection, Selection.End(xlDown)).Select
    For i = 2 To UBound(m)
    s = m(i, 1) & m(i, 3)
        If d1.exists(s) Then
            m1 = d1.Item(s)
            m1(2) = m1(2) + m(i, 2)
            dd = CDate(Right(m1(4), 10))
            t = DateDiff("m", dd, DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1))
            Select Case True
                Case t > 1
                    m1(4) = m1(4) & "," & m(i, 4)
                Case Len(m1(4)) < 11
                    m1(4) = m1(4) & "-" & DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1)
                Case Right(m1(4), 11) = "," & dd
                    m1(4) = m1(4) & "-" & DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1)
                Case Else
                    m1(4) = Left(m1(4), Len(m1(4)) - 11) & "-" & DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1)
            End Select
            d1(s) = m1
        Else
            For ii = 1 To 3: arr(ii) = m(i, ii): Next
            arr(4) = DateSerial(Year(m(i, 4)), Month(m(i, 4)), 1)
            d1(s) = arr
        End If
    Next
    m1 = d1.Items
    ReDim mf(1 To UBound(m1) + 1, 1 To 4)
    For i = 0 To UBound(m1)
        ss = m1(i)(4)
        For ii = 1 To Len(m1(i)(4)) Step 11
        s = Format(Mid(m1(i)(4), ii, 10), "MMMM YYYY")
        ss = Replace(ss, Mid(m1(i)(4), ii, 10), s)
        Next
        mf(i + 1, 1) = m1(i)(1): mf(i + 1, 2) = m1(i)(2): mf(i + 1, 3) = m1(i)(3): mf(i + 1, 4) = ss
    Next
    Cells(3, "n").Resize(i, 4) = mf
End Sub

Sub SSorter1()
Dim i, k, k_First

i = 3 'Стартовая строка
k_First = ActiveCell.SpecialCells(xlLastCell).Row + 2 'Первая строка сводной таблицы
   
k = k_First
aa = "" 'Здесь храним текст окончания диапазона
With ActiveSheet
  While .Cells(i, 1).Value <> ""
    
    If (.Cells(i, 1).Value = .Cells(k, 1).Value) And (.Cells(i, 3).Value = .Cells(k, 3).Value) Then
      'Если обрабатываем имеющуюся строку
       .Cells(k, 2).Value = (.Cells(k, 2).Value) + (.Cells(i, 2).Value)
       
       NewDate = (Year(.Cells(i, 4).Value) - 2000) * 12 + Month(.Cells(i, 4).Value)
       
       If NewDate - 1 = OldDate Then
          aa = " - " & Format(.Cells(i, 4).Value, "MMMM YYYY")
       Else
          If NewDate <> OldDate Then
          
            If Len(aa) > 1 Then
                .Cells(k, 4).Value = .Cells(k, 4).Value & aa
                aa = ""
            End If
          
            .Cells(k, 4).Value = .Cells(k, 4).Value & ", " & Format(.Cells(i, 4).Value, "MMMM YYYY")
           End If
       End If
       OldDate = NewDate
    Else
      'Новая сводная строка
       If .Cells(k, 1).Value <> "" Then
          If Len(aa) > 1 Then
            .Cells(k, 4).Value = .Cells(k, 4).Value & aa
            aa = ""
          End If
          k = k + 1
       End If
       .Cells(k, 1).Value = .Cells(i, 1).Value
       .Cells(k, 3).Value = .Cells(i, 3).Value
       .Cells(k, 2).Value = .Cells(i, 2).Value
       .Cells(k, 4).Value = "" & Format(.Cells(i, 4).Value, "MMMM YYYY")
       OldDate = (Year(.Cells(i, 4).Value) - 2000) * 12 + Month(.Cells(i, 4).Value)
    End If
    
    i = i + 1
  Wend
          
  If Len(aa) > 1 Then
       .Cells(k, 4).Value = .Cells(k, 4).Value & aa
       aa = ""
  End If
End With
End Sub

Исходник = Range("A2").CurrentRegion.Value