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

[Seraf01]

IgorGO, thanks!!!

[Seraf01]

IgorGO, подскажите, пожалуйста, что менять в коде, если столбец из которого выбирается максимальное значение стоит левее(или правее) на n-столбцов от результатирующего? :-)

[IgorGO]

Sub SetMax()
  Const c1 As Long = 4, c2 As Long = 67, c3 As Long = 70
  Dim lr As Long, r As Long, c As Long, tm As Double, lc As Long
  tm = Timer
  Application.EnableEvents = False:  Application.ScreenUpdating = False:
  Columns(1).Insert
  lr = Cells(Rows.Count, 5).End(xlUp).Row
  lc = Cells(9, 1).End(xlToRight).Column
  Range(Cells(10, 1), Cells(lr, 1)).Formula = "=row()"
  Range(Cells(10, 1), Cells(lr, 1)).Copy
  Cells(10, 1).PasteSpecial Paste:=xlPasteValues
  With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Cells(9, c1).Resize(lr - 8, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Cells(9, c2).Resize(lr - 8, 1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange Cells(9, 1).Resize(lr - 8, lc): .Header = xlYes: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    r = 10
    Do While r < lr
      c = WorksheetFunction.CountIf(Range(Cells(r, c1), Cells(lr, c1)), Cells(r, c1))
      Range(Cells(r, c3), Cells(r + c - 1, c3)) = Cells(r, c2)
      r = r + c
    Loop
    .SortFields.Clear
    .SortFields.Add Key:=Range("A9:A" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Cells(9, 1).Resize(lr - 8, lc): .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

добавил строку констант в начале (и чуть поправил код)
с1, с2, с3 - номера колонок Фактор, Значение, Макс

[Seraf01]

Круто, спасибо!!! Удобно и эффективно!.

[Seraf01]

вот незадача, выдает ошибку

[IgorGO]

Sub SetMax()
  Const c1 As Long = 4, c2 As Long = 67, c3 As Long = 70
  Dim lr As Long, r As Long, c As Long, tm As Double, lc As Long
  tm = Timer
  Application.EnableEvents = False:  Application.ScreenUpdating = False:
  Columns(1).Insert
  lr = Cells(Rows.Count, c1+1).End(xlUp).Row
  lc = Cells(9, 2).End(xlToRight).Column
  Range(Cells(10, 1), Cells(lr, 1)).Formula = "=row()"
  Range(Cells(10, 1), Cells(lr, 1)).Copy
  Cells(10, 1).PasteSpecial Paste:=xlPasteValues
  With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Cells(9, c1+1).Resize(lr - 8, 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SortFields.Add Key:=Cells(9, c2+1).Resize(lr - 8, 1), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange Cells(9, 1).Resize(lr - 8, lc): .Header = xlYes: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
    r = 10
    Do While r < lr
      c = WorksheetFunction.CountIf(Range(Cells(r, c1+1), Cells(lr, c1+1)), Cells(r, c1))
      Range(Cells(r, c3+1), Cells(r + c - 1, c3+1)) = Cells(r, c2+1)
      r = r + c
    Loop
    .SortFields.Clear
    .SortFields.Add Key:=Range("A9:A" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Cells(9, 1).Resize(lr - 8, lc): .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

думаете я помню все что написал... как бы не так, забыл что на лист добавлялась колонка 1 (а потом сносилась) так что Вы этого и не замечали.
везде в тексте, где встречались с1, с2, с3 их следовало заменить на с1+1, с2+1, с3+1. уже заменил))

[Seraf01]

К сожалению есть что-то еще, что не дает нормально работать, после запуска макроса excel зависает, а после принудительной остановки макроса все равно добавляется колонка и ошибка появляется...)