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

[Bocul]

Добрый день,
подскажите, как составить макрос или каким-то иным путем отсортировать несколько блоков с данными в порядке от большего к меньшему, блоки с данными отделяет 1 пустая строка, пример в аттаче.

тестовый.zip

[IgorGO]

подсказываю, я составил макрос нажимая кнопки на клавиатуре в определенном порядке.

Private Sub CommandButton1_Click()
  Dim r1 As Long, r2 As Long
  r1 = 2
  Do While Cells(r1, 1).End(xlDown).Row <> Rows.Count
    r2 = Cells(r1, 1).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
    r1 = r2 + 2
  Loop
End Sub

[Bocul]

Спасибо, все работает четко! Благодарность донесу вечером)

[Bocul]

Игорь,
не поможете реализовать второй макрос на основании полученной таблицы после использования первого макроса.
нужно в каждом блоке с данными определить лучшего (из столбца справа) и записать перед блоком "Лучший специалист - "имя лучшего"

пример в файле тестовый2.zip

[IgorGO]

теперь, видимо, так:

Private Sub CommandButton1_Click()
  Dim r1 As Long, r2 As Long
  r1 = 3
  Do While Cells(r1, 2).End(xlDown).Row <> Rows.Count
    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
    Cells(r1 - 1, 1) = "Лучший специалист - " & Cells(r1, 1):  Cells(r1 - 1, 1).Interior.Color = 5296274
    r1 = r2 + 2
  Loop
End Sub

[Bocul]

Спасибо, то что нужно - только если у нас массивов будет к примеру 50 или 150, нужно их все прорабатывать и в конце проверять пустые строки, т.е. если идет 2 пустые строки считать концом работы.

[IgorGO]

последними данными считаются не 2 пустые, а все пустые за последней строкой с данными. возможно колонка 2 у Вас не пустая, а содержит формулу, которая возвращает "" (пустую строку) на вид там пусто, а на самом деле есть данные - пустая строка. присмотритесь что у Вас за последними данными в колонке 2.

[Bocul]

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

последними данными считаются не 2 пустые, а все пустые за последней строкой с данными. возможно колонка 2 у Вас не пустая, а содержит формулу, которая возвращает "" (пустую строку) на вид там пусто, а на самом деле есть данные - пустая строка. присмотритесь что у Вас за последними данными в колонке 2.

Ошибка происходит когда у нас блок состоит из 1 имени, к примеру

катя 34
оля 23
петя 3
вася 2

саша 423

[IgorGO]

значит так:

Private Sub CommandButton1_Click()
  Dim r1 As Long, r2 As Long
  r1 = 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
    r1 = r2 + 2
  Loop
End Sub

[Bocul]

Да работает, но если в группе 1 человек - то по сути он лучший, можно поправить, извиняюсь за не точности в ТЗ.


И еще вопрос в целях самообразования - как вы задаете цвет
.Interior.Color = 5296274

как определить эти цифры у другого цвета, к примеру красный?