Sub ikki()
     Dim ar(), lr&, i&, j&, s$, n&, idx&, dic, ar2()
     With ActiveSheet
         lr = .Cells(.Rows.Count, "a").End(xlUp).Row
         ar = .Range(.[a1], .Cells(lr, "h")).Value
         ReDim ar2(1 To UBound(ar), 1 To UBound(ar, 2))
         Set dic = CreateObject("scripting.dictionary")
          
         For i = 1 To UBound(ar)
             s = ar(i, 2)
             For j = 3 To 6: s = s & "|" & ar(i, j): Next
             If dic.exists(s) Then
                 idx = dic(s)
                 ar2(idx, 7) = ar2(idx, 7) & " + " & ar(i, 7)
             Else
                 n = n + 1: dic(s) = n
                 For j = 1 To 8: ar2(n, j) = ar(i, j): Next
             End If
         Next
            
         If n Then .Cells(lr + 2, "a").Resize(n, 8).Value = ar2
     End With
End Sub

Sub Макрос1()
'
' Макрос1 Макрос
'
         Range("A1").Select
         Selection.AutoFill Destination:=Range("A1:A45"), Type:=xlFillSeries
         Range("A1:A45").Select
         ActiveWindow.SmallScroll Down:=21
End Sub

Sub Перебор()
     Dim TmpArr()
     Dim Arr()
      
     ' находим последнюю заполненую ячейку в столбике А
     EndRow = Лист1.Range("A1").End(xlDown).Row
     ' заносим в масив все значения из диапазона "А1:Н+EndRow"
     Arr = Лист1.Range("A1", "H" & EndRow).Value
     ' создаем словарь
     Set Dic = CreateObject("Scripting.Dictionary")
     ' Делаем перебор по всем строкам масива
     For i = LBound(Arr) To UBound(Arr)
         Key = ""
         ReDim TmpArr(LBound(Arr, 2) To UBound(Arr, 2))
         ' Создаем уникальній ключ, для оприделения повторений
         For j = 2 To 6
             Key = Key & Trim(Arr(i, j))
         Next j
          
         ' проверяем существование ключа в словаре
         If Dic.Exists(Key) Then
             ' существует - добавляем значение из столбика 7
             TmpArr = Dic(Key)
             TmpArr(7) = TmpArr(7) & "+" & Arr(i, 7)
             Dic(Key) = TmpArr
         Else
             ' не существует - просто заполняем масив значениями из строки
             ReDim TmpArr(LBound(Arr, 2) To UBound(Arr, 2))
             For j = LBound(Arr, 2) To UBound(Arr, 2)
                 TmpArr(j) = Arr(i, j)
             Next j
             ' добавляем в словарь
             Dic.Add Key, TmpArr
         End If
     Next i
     ' переопределяем масив для вывода результата
     ReDim Arr(1 To Dic.Count, LBound(Arr, 2) To UBound(Arr, 2))
     i = 1
     ' делаем перебор ключей по всему словарю
     For Each Key In Dic.keys
         TmpArr = Dic(Key)
         ' перебором значений для заноса данных в результирующий масив
         For j = LBound(TmpArr) To UBound(TmpArr)
             Arr(i, j) = TmpArr(j)
         Next j
         i = i + 1
     Next Key
     ' Очищаем лист2
     Лист2.Cells.ClearContents
     ' заносим масив на лист2
     Лист2.Range("A1", "H" & Dic.Count).Value = Arr
     ' переход на лист2
     Лист2.Activate
End Sub