Sub Объединить()
    
    Dim arr(), lr As Long, i As Long
    
    Application.ScreenUpdating = False
    
    ActiveSheet.Copy After:=ActiveSheet
    ActiveSheet.AutoFilterMode = False
    Rows.Hidden = False
    
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Columns("B"), SortOn:=xlSortOnValues, Order:=xlAscending
    ActiveSheet.Sort.SortFields.Add Key:=Columns("D"), SortOn:=xlSortOnValues, Order:=xlAscending
    ActiveSheet.Sort.SortFields.Add Key:=Columns("E"), SortOn:=xlSortOnValues, Order:=xlAscending
    With ActiveSheet.Sort
        .SetRange Columns("A:H").Rows("3:" & Rows.Count)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    arr() = Range("A1:H" & lr).Value
    For i = UBound(arr) To 4 Step -1
        If arr(i, 2) = arr(i - 1, 2) And arr(i, 4) = arr(i - 1, 4) And arr(i, 5) = arr(i - 1, 5) Then
            arr(i - 1, 6) = arr(i - 1, 6) & "," & arr(i, 6)
            arr(i - 1, 7) = arr(i - 1, 7) + arr(i, 7)
            arr(i, 2) = Empty
        End If
    Next i
    Range("A1:H" & lr).Value = arr()
    
    On Error Resume Next
        Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    
    Application.ScreenUpdating = True
        
End Sub

Sub Объединить()
    
    Dim arr(), lr As Long, i As Long
    
    Application.ScreenUpdating = False
    
    ActiveSheet.Copy After:=ActiveSheet
    ActiveSheet.AutoFilterMode = False
    Rows.Hidden = False
    
    ActiveSheet.Sort.SortFields.Clear
    'здесь надо указать столбец, по которому проводить сортировку
    'столбцы можно менять местами, выбирая в какой последовательности нужно сортировать столбцы
    ActiveSheet.Sort.SortFields.Add Key:=Columns("B"), SortOn:=xlSortOnValues, Order:=xlAscending
    ActiveSheet.Sort.SortFields.Add Key:=Columns("C"), SortOn:=xlSortOnValues, Order:=xlAscending
    ActiveSheet.Sort.SortFields.Add Key:=Columns("D"), SortOn:=xlSortOnValues, Order:=xlAscending
    ActiveSheet.Sort.SortFields.Add Key:=Columns("E"), SortOn:=xlSortOnValues, Order:=xlAscending
    With ActiveSheet.Sort
        .SetRange Columns("A:H").Rows("3:" & Rows.Count)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    
    lr = Cells(Rows.Count, "B").End(xlUp).Row
    arr() = Range("A1:H" & lr).Value
    For i = UBound(arr) To 4 Step -1
        'здесь надо добавить сравнение для соседних строк столбца
        If arr(i, 2) = arr(i - 1, 2) And arr(i, 3) = arr(i - 1, 3) And arr(i, 4) = arr(i - 1, 4) And _
                arr(i, 5) = arr(i - 1, 5) Then
            arr(i - 1, 6) = arr(i - 1, 6) & "," & arr(i, 6)
            arr(i - 1, 7) = arr(i - 1, 7) + arr(i, 7)
            arr(i, 2) = Empty
        End If
    Next i
    Range("A1:H" & lr).Value = arr()
    
    On Error Resume Next
        Columns("B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    
    Application.ScreenUpdating = True
        
End Sub

Option Explicit

Dim arr

Sub continuous_sequence()
    Dim rng As Range
    Dim sNew As String, Symb As String
    Dim i As Long, j As Long

    'On Error Resume Next

    With ActiveSheet
        For i = 3 To .UsedRange.Rows.Count
            Set rng = .Cells(i, 6)
            arr = Split(rng, ",")
            For j = LBound(arr) + 1 To UBound(arr)
                If CLng(arr(j - 1)) = CLng(arr(j) - 1) Then
                    Symb = ","
                Else
                    Symb = "-"
                End If
                sNew = func_sNew(sNew, Symb, j)
            Next
            'rng.Value = sNew 'для записи = раскомментировать
Debug.Print sNew
            sNew = ""
        Next
    End With
End Sub

Function func_sNew(ByRef sNew As String, _
                   ByVal Symb As String, _
                   j As Long)
    'поставить символ
    sNew = sNew & arr(j - 1) & Symb & arr(j)
    ' отрезать слева по символу
    If j < UBound(arr) Then _
       sNew = Left(sNew, InStrRev(sNew, Symb))

    func_sNew = sNew
End Function