Sub arhiv_DoubleDel()
Dim Rw1 As Long, Rw2 As Long, cCm As Long, iCm As Long, iRw As Long
Dim Sums As Long, Par As Variant, manyPars As Boolean, lRw As Long
Dim tOK As Boolean, fndRg As Range, i As Long, fAdr As String
Dim fndRw As Long

'MsgBox "Программа DoubleDel - для поиска и удаления повторяющихся строк по заданным парамерам", vbInformation

cCm = 3 'Cells(77, 200).Value  'колонка с количеством
Rw1 = 1 'Cells(6, 200).Value + 1 '1я строка основной таблицы со значениями
Rw2 = 90 ' Cells(7, 200).Value 'последняя строка основной таблицы
If Trim(Cells(26, 200).Text) = "" Then  'проверка ведется по единственному параметру
    manyPars = False
    iCm = 2 'Cells(25, 200).Value 'колонка поиска
Else
    manyPars = True
    'в колонке 200, с 25 по 49 ряд хранятся колонки с параметрами, по которым производится сверка
    'параметры расположены в порядке приоритетов. По 1му параметру производится поиск
    lRw = Cells(25, 200).End(xlDown).Row
    Par = Application.WorksheetFunction.Transpose(Range(Cells(25, 200), Cells(lRw, 200)).Value)
    iCm = Par(LBound(Par)) 'колонка поиска
End If
iRw = Rw1
Do While iRw < Rw2
    'If iRw = 40 Then Stop
    'проверка на наличие непустой ячейки для поиска
    If Trim(Cells(iRw, iCm).Value) = "" Then
        tOK = False
        If manyPars Then
            For i = (LBound(Par) + 1) To UBound(Par)
                iCm = Par(i)
                If Trim(Cells(iRw, iCm).Value) <> "" Then tOK = True: Exit For
            Next
        End If
    Else
        tOK = True
    End If
    
    If tOK Then 'поиск непустой ячейки возможен
    tOK = False
    Sums = Cells(iRw, cCm).Value
    Set fndRg = Range(Cells(iRw + 1, iCm), Cells(Rw2, iCm)).Find(Cells(iRw, iCm).Value, , xlValues, xlWhole, xlByRows)
    If Not (fndRg Is Nothing) Then
    Debug.Print "Ищем: " & Cells(iRw, iCm).Value
    Debug.Print "Нашли: " & fndRg.Value
    Debug.Print "iRw: " & iRw & " - Rw2: " & Rw2 & " - fndRw: " & fndRg.Row
        fAdr = fndRg.Address
        Do
            fndRw = fndRg.Row
            tOK = True
            If manyPars Then
                For i = LBound(Par) To UBound(Par)
                    If Par(i) <> iCm Then
                    If Cells(fndRw, Par(i)).Value <> Cells(iRw, Par(i)).Value Then tOK = False: Exit For
                    End If
                Next
            End If
            If tOK Then 'найденная строка - дублер просматриваемой iRw
                Sums = Sums + Cells(fndRw, cCm).Value
                Rows(fndRw).Delete
                Rw2 = Rw2 - 1
            End If
            Set fndRg = Range(Cells(iRw + 1, iCm), Cells(Rw2, iCm)).FindNext(Cells(fndRw, iCm))
            If Not (fndRg Is Nothing) Then
                If fndRg.Address <> fAdr Then tOK = True Else tOK = False
            Else
                tOK = False
            End If
            If tOK Then
                Debug.Print "Нашли: " & fndRg.Value
                Debug.Print "iRw: " & iRw & " - Rw2: " & Rw2 & " - fndRw: " & fndRg.Row
            End If
        Loop While tOK
    Cells(iRw, cCm).Value = Sums
    End If
    If manyPars Then iCm = Par(LBound(Par)) 'восстанавливаем основной поиск
    End If 'пропускаем поиск по пустым ячейкам
iRw = iRw + 1
Loop
End Sub

Function arhiv_CurRegion(Optional firstCell As Range, Optional lastCell As Range) As Boolean
Dim selRng As Range
Dim Rw1 As Long, Rw2 As Long, Cm1 As Long, Cm2 As Long

On Error Resume Next

'для начала пользователь должен открыть нужный лист и выбрать ячейку в таблице
Set selRng = Application.InputBox("Выберите любую непустую ячейку в рабочей таблице (включая заголовки)", "Выбор рабочей таблицы", Type:=8)
If selRng Is Nothing Then
    MsgBox "Может, в следующий раз", vbInformation, "Выбор рабочей таблицы"
    sel_CurRegion = False
Else
    Set firstCell = selRng.CurrentRegion.Cells(1, 1)
    Rw1 = firstCell.Row
    Cm1 = firstCell.Column
    Cm2 = selRng.CurrentRegion.Columns(selRng.CurrentRegion.Columns.Count).Column
    Rw2 = selRng.CurrentRegion.Rows(selRng.CurrentRegion.Rows.Count).Row
    Set lastCell = Cells(Rw2, Cm2)
    sel_CurRegion = True
    Cells(6, 200).Value = Rw1
    Cells(6, 201).Value = Cm1
    Cells(7, 200).Value = Rw2
    Cells(7, 201).Value = Cm2
End If
Cells(5, 200).Value = sel_CurRegion
End Function