Страницы: 1
RSS
10 максимальных значений из диапазона в абсолютном выражении
 
Добрый день!
Написал код, который находит первые 10 строк с максимальными значениями в диапазоне rng (столбцы 5, 7, 9) и подкрашивает соответствующие ячейки в столбце 1 (ниже). А как теперь сделать так чтобы код находил 10 максимальных АБСОЛЮТНЫХ значений? Уже голову сломал, ничего не выходит, прошу подсказки.
Код
Dim rng As Range

Set rng1 = Range(Cells(1, 5), Cells(1000, 5))
Set rng2 = Range(Cells(1, 7), Cells(1000, 7))
Set rng3 = Range(Cells(1, 9), Cells(1000, 9))
Set rng = Union(rng1, rng2, rng3)

 
With WorksheetFunction
        For i = 1 To 10
            For ii = 1 To 1000
                    If .Max(Abs(Cells(ii, 5).Value), Abs(Cells(ii, 7).Value), Abs(Cells(ii, 9).Value)) = .Large(rng, i) Then
                            Cells(ii, 1).Interior.Color = RGB(146, 208, 80)
                            GoTo metka
                    End If
            Next
metka:
        Next

End With

 
Файл-пример с полным кодом?
Кстати, если среди топ-10 есть повторы ИЛИ если в одной строке есть более одного числа из топ-10, то будет закрашено менее 10 ячеек.
Изменено: Казанский - 03.04.2018 13:11:45
 
Файл приложил.
Повторов не будет.
А вот когда в 1 строке несколько значений из топ-10, есть такое, я уже тоже понял, пытался избежать этого нахождением максимального по строке:
.Max(Abs(Cells(ii, 5).Value), Abs(Cells(ii, 7).Value), Abs(Cells(ii, 9).Value))
А дальше ставить дополнительный счетчик чтобы все-таки считало до 10. Коряво но вроде получилось.  
 
Файл
 
Вроде получилось самому допетрить, на словаре, может не лучшее решение, выглядит коряво мой код, но вроде работает...
Код
Dim mySum As Double
Dim lRow  As Long, i, ii, k
Dim rng As Range
Dim a() As Variant
Dim r As Range, t

Set rng1 = Range(Cells(1, 5), Cells(100, 5))
Set rng2 = Range(Cells(1, 7), Cells(100, 7))
Set rng3 = Range(Cells(1, 9), Cells(100, 9))
Set rng = Union(rng1, rng2, rng3)

   Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")

   dic.CompareMode = vbTextCompare
   For Each r In rng
        If Not dic.Exists(r.Value) Then dic.Add r.Value, ""
        dic.Item(r.Value) = dic.Item(Abs(r.Value))
   Next r
   
s = 0
With WorksheetFunction
        For i = 1 To 30
            For ii = 1 To 100
                If .Max(Abs(Cells(ii, 5).Value), Abs(Cells(ii, 7).Value), Abs(Cells(ii, 9).Value)) = .Large(dic.Keys, i) Then
                    If t = ii Then GoTo metka
                    Cells(ii, 1).Interior.Color = RGB(146, 208, 80)
                    Cells(ii, 1).Value = s
                    t = ii
                    s = s + 1
                    GoTo metka
                End If
            Next
metka:
If s = 10 Then Exit For
        Next
 
End With
Страницы: 1
Наверх