Определение max значения при условии

[Seraf01]

Всем привет! Помогите реализовать следующую формулу программным кодом: ячейка Ci {=max(if($A$1:$A$100=Ai;$B$1:$B$100 ))}, i = 1,...,20 000. Прилагаю пример. Всем заранее большущие спасибо!

[Ves67]

Sub pMax()
Dim dic As Object
Dim i As Long
Set dic = CreateObject("Scripting.Dictionary")
For i = 2 To 11
If dic.Exists(Cells(i, 1).Value) Then
If dic.Item(Cells(i, 1).Value) < Cells(i, 2) Then
dic.Item(Cells(i, 1).Value) = Cells(i, 2)
End If
Else
dic.Add Cells(i, 1).Value, Cells(i, 2).Value
End If
Next
For i = 2 To 11
Cells(i, 3) = dic.Item(Cells(i, 1).Value)
Next
End Sub

[IgorGO]

Sub SetMaxVal()
  Dim r As Long
  For r = 2 To 11
    Cells(r, 3) = MaxBEqA(Range("A2:A11"), Cells(r, 1))
  Next
End Sub


Function MaxBEqA(Rg As Range, V)
  Dim r As Long, m As Double
  m = Application.Min(Rg.Offset(0, 1))
  For r = Rg.Row To Rg.Row + Rg.Rows.Count - 1
    If Rg.Cells(1 + r - Rg.Row) = V And Rg.Cells(1 + r - Rg.Row).Offset(0, 1) > m Then m = Rg.Cells(1 + r - Rg.Row).Offset(0, 1)
  Next
  MaxBEqA = m
End Function

[SAS888]

"До кучи" предложу еще один вариант. Это существенно проще, но есть условие: рабочая таблица должна иметь заголовки. Думаю, это не критично.

Sub qq()
    Dim i As Integer, j As Integer: Application.ScreenUpdating = False
    j = Cells(Rows.Count, 1).End(xlUp).Row + 1: Cells(j, 1) = [A1]
    For i = 2 To 11
        Cells(j + 1, 1) = Cells(i, 1)
        Cells(i, 3) = Application.DMax([A1:B11], 2, Cells(j, 1).Resize(2))
    Next
    Cells(j, 1).Resize(2).ClearContents
End Sub

Пример во вложении.

[Seraf01]

Всем большое спасибо, выручили!!!

[Seraf01]

Отдельное спасибо, всего за 3 мин. макрос обработал 20 000 строк, пока это рекорд по времени!

[Seraf01]

Сообщение от SAS888

"До кучи" предложу еще один вариант. Это существенно проще, но есть условие: рабочая таблица должна иметь заголовки. Думаю, это не критично.

Sub qq()
    Dim i As Integer, j As Integer: Application.ScreenUpdating = False
    j = Cells(Rows.Count, 1).End(xlUp).Row + 1: Cells(j, 1) = [A1]
    For i = 2 To 11
        Cells(j + 1, 1) = Cells(i, 1)
        Cells(i, 3) = Application.DMax([A1:B11], 2, Cells(j, 1).Resize(2))
    Next
    Cells(j, 1).Resize(2).ClearContents
End Sub

Пример во вложении.

Всего за 3 мин. макрос обработал 20 000 строк, пока это рекорд по времени!

[IgorGO]

ну, если реальные данные и со временем побороться...

Sub SetMax()
  Dim lr As Long, r As Long, c As Long, tm As Double
  tm = Timer
  Application.EnableEvents = False:  Application.ScreenUpdating = False:
  Columns(1).Insert
  lr = Cells(Rows.Count, 2).End(xlUp).Row
  Range(Cells(2, 1), Cells(lr, 1)).Formula = "=row()"
  Range(Cells(2, 1), Cells(lr, 1)).Copy
  Cells(2, 1).PasteSpecial Paste:=xlPasteValues
  With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("B2:B" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("C2:C" & lr), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange Range("A1:C" & lr): .Header = xlYes: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    r = 2
    Do While r < lr
      c = WorksheetFunction.CountIf(Range(Cells(r, 2), Cells(lr, 2)), Cells(r, 2))
      Range(Cells(r, 4), Cells(r + c - 1, 4)) = Cells(r, 3)
      r = r + c
    Loop
    .SortFields.Clear
    .SortFields.Add Key:=Range("A2:A" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A1:D" & lr): .Header = xlYes: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
  End With
  Columns(1).Delete:  Application.EnableEvents = True:  Application.ScreenUpdating = True
  Cells(1, 1) = Timer - tm
End Sub

в ячейке А1 - время в секундах, зависит от данных но может быть и меньше 1 сек.

[Seraf01]

IgorGO, макрос обработал 19591 строчку за 63 сек., это то что надо, вам огромное спасибо!) Но к сожалению, я не смог настроить макрос под необходимую форму, помогите плиз!)

[IgorGO]

Sub SetMax()
  Dim lr As Long, r As Long, c As Long, tm As Double
  tm = Timer
  Application.EnableEvents = False:  Application.ScreenUpdating = False:
  Columns(1).Insert
  lr = Cells(Rows.Count, 5).End(xlUp).Row
  Range(Cells(12, 1), Cells(lr, 1)).Formula = "=row()"
  Range(Cells(12, 1), Cells(lr, 1)).Copy
  Cells(12, 1).PasteSpecial Paste:=xlPasteValues
  With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("E11:E" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Range("AS11:AS" & lr), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange Range("A11:AT" & lr): .Header = xlYes: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    r = 12
    Do While r < lr
      c = WorksheetFunction.CountIf(Range(Cells(r, 5), Cells(lr, 5)), Cells(r, 5))
      Range(Cells(r, 46), Cells(r + c - 1, 46)) = Cells(r, 45)
      r = r + c
    Loop
    .SortFields.Clear
    .SortFields.Add Key:=Range("A11:A" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range("A11:AT" & lr): .Header = xlYes: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
  End With
  Columns(1).Delete:  Application.EnableEvents = True:  Application.ScreenUpdating = True
  MsgBox Timer - tm
End Sub

20 тыс.строк при 64 разных значениях в колонке Д, процедура сделала за 2.5 сек.