Макрос - сортировка по блокам

[IgorGO]

...color = RGB(255,0,0) - будет красный
RGB = Red, Green, Blue
сколько красного, зеленого, синего добавить в цвет (добавлять можно от 0 до 255)
если всех поравну будут оттенки серого от черного (0,0,0) до белого (255,255,255)

это покажет каким цветом залита активная ячейка:
sub CellColor
msgbox activecell.interior.color
end sub

[Bocul]

Разобрался, спасибо!

Можете поправить скрипт, что бы если 1 человек в группе, то перед ним выводить "Лучший специалист - имя" тоже, так как если много листов получаются пустые строки

тестовый3.zip

[IgorGO]

извините.

Private Sub CommandButton1_Click()
  Dim r1 As Long, r2 As Long
  r1 = 3:  r2 = 3
  Do While Cells(r1, 2).End(xlDown).Row <> Rows.Count
    If Cells(r1 + 1, 2) <> "" Then
      r2 = Cells(r1, 2).End(xlDown).Row
      ActiveSheet.Sort.SortFields.Clear
      ActiveSheet.Sort.SortFields.Add Key:=Range("B" & r1 & ":B" & r2), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
      With ActiveSheet.Sort
          .SetRange Range("A" & r1 & ":B" & r2): .Header = xlGuess: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
          .Apply
      End With
    End If
    Cells(r1 - 1, 1) = "Лучший специалист - " & Cells(r1, 1):  Cells(r1 - 1, 1).Interior.Color = 5296274
    r2 = r2 + 2:  r1 = r2
  Loop
End Sub

[Bocul]

Не работает (т.е. не добавляет фразу если у нас массив из 1-го имя), может - я что-то не верно делаю?

[IgorGO]

Private Sub CommandButton1_Click()
  Dim r1 As Long, r2 As Long
  r1 = 3:  r2 = 3
  Do
    If Cells(r1 + 1, 2) <> "" Then
      r2 = Cells(r1, 2).End(xlDown).Row
      ActiveSheet.Sort.SortFields.Clear
      ActiveSheet.Sort.SortFields.Add Key:=Range("B" & r1 & ":B" & r2), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
      With ActiveSheet.Sort
          .SetRange Range("A" & r1 & ":B" & r2): .Header = xlGuess: .MatchCase = False: .Orientation = xlTopToBottom: .SortMethod = xlPinYin
          .Apply
      End With
    End If
    Cells(r1 - 1, 1) = "Лучший специалист - " & Cells(r1, 1):  Cells(r1 - 1, 1).Interior.Color = 5296274
    r2 = r2 + 2:  r1 = r2
  Loop Until Cells(r1, 2).End(xlDown).Row = Rows.Count
End Sub

если в качестве данных был мощный список из 1 группы, состоящей из 1 человека, то в том варианте не добавило бы. сейчас - добавит.