Function TransposeArrayX1(ByVal arr As Variant) As Variant
     ' Пользовательская функция для транспонирования массива
    Dim tempArray As Variant
     ReDim tempArray( LBound(arr, 1) To UBound(arr, 1))
     
         For Y = LBound(arr, 1) To UBound(arr, 1)
             tempArray( Y) = arr(Y, 1)
         Next Y
     
     TransposeArrayX1 = tempArray
End Function

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

Public Enum tpCommColor
    cmtWhite 'As Long
    cmtGreen 'As Long
    cmtBlue 'As Long
    cmtRed 'As Long
    cmtOrange 'As Long
    cmtYellow 'As Long
    cmtDarkGreen 'As Long
    cmtDarkBlue 'As Long
    cmtDarkRed 'As Long
    cmtDarkOrange 'As Long
    cmtDarkYellow 'As Long
End Enum

Public Enum plCommFill
    cmtForeColor 'As Long
    cmtBorderColor 'As Long
    cmtTextColor 'As Long
End Enum

'==================
Sub t_altCommInd()
altCommInd cmtDarkYellow 'photo

ActiveCell.Offset(1, 0).Select
altCommInd cmtDarkBlue 'price

ActiveCell.Offset(1, 0).Select
altCommInd cmtDarkGreen 'info

ActiveCell.Offset(1, 0).Select
altCommInd cmtDarkRed 'need

ActiveCell.Offset(1, 0).Select
altCommInd cmtDarkOrange 'alarm
End Sub

'==================
Sub altCommInd(cmtTypeColor As tpCommColor)
Dim oldNum As MsoRGBType
 
With Selection.Interior
    If .Pattern = xlNone Then
        oldNum = 0
    Else
        oldNum = .Color
    End If
    .Pattern = xlPatternLinearGradient
    .Gradient.Degree = -12 '-20
    .Gradient.ColorStops.Clear
End With
With Selection.Interior.Gradient.ColorStops.Add(0)
    If oldNum <> 0 Then
        .Color = oldNum
    Else
        .ThemeColor = xlThemeColorDark1
    End If
    .TintAndShade = 0
End With
  
With Selection.Interior.Gradient.ColorStops.Add(0.799)
    If oldNum <> 0 Then
        .Color = oldNum
    Else
        .ThemeColor = xlThemeColorDark1
    End If
    .TintAndShade = 0
End With
 
With Selection.Interior.Gradient.ColorStops.Add(0.8 )
    .Color = numCommColorRGB(cmtTypeColor)
    .TintAndShade = 0
End With
 
With Selection.Interior.Gradient.ColorStops.Add(1)
    .Color = numCommColorRGB(cmtTypeColor)
    .TintAndShade = 0
End With
End Sub

'==================
Sub altCommInd_Del()
Dim oldNum As MsoRGBType, tpPat As XlPattern
Dim numTheme As Long, zoneColor As ColorStop

With ActiveCell.Interior
    tpPat = xlPatternSolid
    Set zoneColor = .Gradient.ColorStops.Item(1)
    
    numTheme = zoneColor.ThemeColor   
    If numTheme = xlThemeColorDark1 Then
        oldNum = 0
    Else
        oldNum = zoneColor.Color
    End If
    .Pattern = tpPat
    If oldNum = 0 Then
        .ThemeColor = xlThemeColorDark1
    Else
        .Color = oldNum
    End If
End With
End Sub


'==================
Function numCommColorRGB(ColorName As tpCommColor, Optional ColorPlace As plCommFill = cmtForeColor) As MsoRGBType
If ColorPlace = cmtForeColor Then
    If ColorName = cmtGreen Then
        numCommColorRGB = RGB(218, 253, 167) '.Color = 11009498
    ElseIf ColorName = cmtBlue Then
        numCommColorRGB = RGB(158, 234, 255) '.Color = 16771742
    ElseIf ColorName = cmtRed Then
        numCommColorRGB = RGB(255, 162, 161) '.Color = 10593023
    ElseIf ColorName = cmtOrange Then
        numCommColorRGB = RGB(250, 192, 144) '.Color = 749285
    ElseIf ColorName = cmtYellow Then
        numCommColorRGB = RGB(245, 253, 56) '.Color = 3735029
    ElseIf ColorName = cmtDarkGreen Then
        numCommColorRGB = RGB(0, 176, 80)
    ElseIf ColorName = cmtDarkBlue Then
        numCommColorRGB = RGB(0, 112, 192)
    ElseIf ColorName = cmtDarkRed Then
        numCommColorRGB = RGB(255, 0, 0)
    ElseIf ColorName = cmtDarkOrange Then
        numCommColorRGB = RGB(229, 110, 0)
    ElseIf ColorName = cmtDarkYellow Then
        numCommColorRGB = RGB(154, 150, 0)
    End If
ElseIf ColorPlace = cmtBorderColor Then
    If ColorName = cmtGreen Then
        numCommColorRGB = RGB(41, 97, 66) '.ThemeColor = 7
    ElseIf ColorName = cmtBlue Then
        numCommColorRGB = RGB(30, 15, 121) '.ThemeColor = 9
    ElseIf ColorName = cmtRed Then
        numCommColorRGB = RGB(189, 26, 13) '.ThemeColor = 6 '.Color = -16777024
    ElseIf ColorName = cmtOrange Then
        numCommColorRGB = RGB(180, 86, 8 ) '.ThemeColor = 10
    ElseIf ColorName = cmtYellow Then
        numCommColorRGB = RGB(127, 133, 1) '.ThemeColor = 1
    End If
Else
    numCommColorRGB = RGB(255, 255, 255)
End If
End Function