Макрос для выбора цены и количества

Sub Проставить_максимальные_цены()
    Const StartRow% = 5
    Dim A, i&, LastRow&, S$, Dic2
    With Application
         .Calculation = xlCalculationManual
         .ScreenUpdating = False
         LastRow = Cells(Rows.Count, 2).End(xlUp).Row
         A = ActiveSheet.Range("A1:R" & LastRow).Value
         Set Dic2 = CreateObject("Scripting.Dictionary")
         With CreateObject("Scripting.Dictionary")
             For i = StartRow To UBound(A)
                 S = Trim$(A(i, 2)) & Trim$(A(i, 8))
                 If .Item(S) < A(i, 15) Then
                    .Item(S) = A(i, 15)
                    Dic2.Item(S) = A(i, 17)
                 End If
             Next i
             For i = StartRow To UBound(A)
                 S = Trim$(A(i, 2)) & Trim$(A(i, 8))
                 If A(i, 15) < .Item(S) Then
                    Cells(i, 15) = .Item(S)
                    Cells(i, 17) = Dic2.Item(S)
                 End If
             Next i
         End With
         Set Dic2 = Nothing
        .Calculation = xlCalculationAutomatic
    End With
End Sub
 
Sub Суммировать_строки()
    Const StartRow% = 5
    Dim A, U() As Boolean, i&, LastRow&, S$
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        LastRow = Cells(Rows.Count, 2).End(xlUp).Row
        A = ActiveSheet.Range("A1:R" & LastRow).Value
        ReDim U(1 To UBound(A))
        With CreateObject("Scripting.Dictionary")
        For i = StartRow To UBound(A)
            S = Trim$(A(i, 2)) & Format$(A(i, 7)) & Trim$(A(i, 8))
            If .Exists(S) Then
                U(i) = True
            End If
            .Item(S) = .Item(S) + A(i, 14)
        Next i
        For i = UBound(A) To StartRow Step -1
            If U(i) Then
               Rows(i).Delete Shift:=xlUp
            Else
               S = Trim$(A(i, 2)) & Format$(A(i, 7)) & Trim$(A(i, 8))
               Cells(i, 14) = .Item(S)
            End If
        Next i
        End With
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Sub Проставить_максимальные_цены()
    Const StartRow% = 5
    Dim A, i&, LastRow&, S$, Dic2, Dic3
    With Application
         .Calculation = xlCalculationManual
         .ScreenUpdating = False
         LastRow = Cells(Rows.Count, 2).End(xlUp).Row
         A = ActiveSheet.Range("A1:R" & LastRow).Value
         Set Dic2 = CreateObject("Scripting.Dictionary")
         Set Dic3 = CreateObject("Scripting.Dictionary")
         With CreateObject("Scripting.Dictionary")
             For i = StartRow To UBound(A)
                 S = Trim$(A(i, 2)) & Trim$(A(i, 8))
                 If .Item(S) < A(i, 15) Then
                    .Item(S) = A(i, 15)
                 End If
                 If Dic2.Item(S) < A(i, 16) Then
                    Dic2.Item(S) = A(i, 16)
                 End If
                 If Dic3.Item(S) < A(i, 17) Then
                    Dic3.Item(S) = A(i, 17)
                 End If
             Next i
             For i = StartRow To UBound(A)
                 S = Trim$(A(i, 2)) & Trim$(A(i, 8))
                 If A(i, 15) < .Item(S) Then
                    Cells(i, 15) = .Item(S)
                 End If
                 If A(i, 16) < Dic2.Item(S) Then
                    Cells(i, 16) = Dic2.Item(S)
                 End If
                 If A(i, 17) < Dic3.Item(S) Then
                    Cells(i, 17) = Dic3.Item(S)
                 End If
             Next i
         End With
         Set Dic2 = Nothing: Set Dic3 = Nothing
        .Calculation = xlCalculationAutomatic
    End With
End Sub
 
Sub Оставить_строки_с_макс_количеством()
    Const StartRow% = 5
    Dim A, N&(), i&, LastRow&, S$
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        LastRow = Cells(Rows.Count, 2).End(xlUp).Row
        A = ActiveSheet.Range("A1:R" & LastRow).Value
        ReDim N(0 To UBound(A))
        With CreateObject("Scripting.Dictionary")
        For i = StartRow To UBound(A)
            S = Trim$(A(i, 2)) & Format$(A(i, 7)) & Trim$(A(i, 8))
            If N(.Item(S)) < A(i, 14) Then
               .Item(S) = i
               N(.Item(S)) = A(i, 14)
            End If
        Next i
        For i = UBound(A) To StartRow Step -1
            S = Trim$(A(i, 2)) & Format$(A(i, 7)) & Trim$(A(i, 8))
            If .Item(S) <> i Then Rows(i).Delete Shift:=xlUp
        Next i
        End With
        .Calculation = xlCalculationAutomatic
    End With
End Sub