Здравствуйте. Задача скорее всего простая, но решения на форуме не нашел. В первом столбце - названия групп, во втором - их значения. https://yadi.sk/i/mrb8GZ2BB8SBSg
Нужно отсортировать строки по размерам групп, то есть по количеству повторяющихся значений в первом столбце. Должно получиться так: https://yadi.sk/i/DSoIefszexc8Ig
Вот пример. На первом листе - что имеем изначально, на втором листе - что нужно получить. На третьем листе - идеальный вариант, который хотелось бы получить - объединение ячеек названий групп и добавление пустых строк между группами.
Метод Sort не знаю воспользовался макрорекордером, может кто-то красивее напишет.
Код
Sub SENdsfjk(): Dim Rg1 As Range, kSt&, Tp$
kSt = Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Sort.SortFields.Add Key:=Range("B2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A2:B" & kSt)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
For i = 3 To kSt
If Cells(i, 1) = Cells(i - 1, 1) Then
Tp = Cells(i, 1)
If Rg1 Is Nothing Then Set Rg1 = Union(Cells(i, 1), Cells(i - 1, 1)) Else Set Rg1 = Union(Rg1, Cells(i, 1))
Else
If Not Rg1 Is Nothing Then Rg1.ClearContents: Rg1.Merge: Rg1.Value = Tp: Set Rg1 = Nothing
End If
Next i
If Not Rg1 Is Nothing Then Rg1.ClearContents: Rg1.Merge: Rg1.Value = Tp
End Sub
Оказывается макрорекордер в Excel 2010 пишет кучу лишнего. Так немного короче
Код
Sub SENdsfjk1(): Dim Rg1 As Range, kSt&, Tp$
kSt = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & kSt).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
For i = 3 To kSt
If Cells(i, 1) = Cells(i - 1, 1) Then
Tp = Cells(i, 1)
If Rg1 Is Nothing Then Set Rg1 = Union(Cells(i, 1), Cells(i - 1, 1)) Else Set Rg1 = Union(Rg1, Cells(i, 1))
Else
If Not Rg1 Is Nothing Then Rg1.ClearContents: Rg1.Merge: Rg1.Value = Tp: Set Rg1 = Nothing
End If
Next i
If Not Rg1 Is Nothing Then Rg1.ClearContents: Rg1.Merge: Rg1.Value = Tp
End Sub
Автор еще хотел добавить пустые строки в предыдущем нет. В коде ниже есть
Код
Sub SENdsfjk2(): Dim Rg1 As Range, kSt&, Tp$
kSt = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & kSt).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
For i = kSt To 3 Step -1
If Cells(i, 1) = Cells(i - 1, 1) Then
Tp = Cells(i, 1)
If Rg1 Is Nothing Then Set Rg1 = Union(Cells(i, 1), Cells(i - 1, 1)) Else Set Rg1 = Union(Rg1, Cells(i - 1, 1))
Else
If Not Rg1 Is Nothing Then Rg1.ClearContents: Rg1.Merge: Rg1.Value = Tp: Set Rg1 = Nothing
If i > 3 Then Rows(i).Insert
End If
Next i
If Not Rg1 Is Nothing Then Rg1.ClearContents: Rg1.Merge: Rg1.Value = Tp
End Sub
Евгений Смирнов, а нужны ли все параметры, которые выдал макрорекодер в 2002 (и такие динозавры используются?)? Нужна ли строка комментария ' Макрос1 Макрос? Речь о том, что при автозаписи в любой версии пишется много чего лишнего. Попробуйте записать значение в ячейку. В 2002 лишних Select'ов не будет?
И я не уверен, что фильтрация, записанная в 2010, нормально отработает в 2002
Евгений Смирнов написал: Автор еще хотел добавить пустые строки...
Всем большое спасибо за отзывчивость. Я остановился на этом варианте Евгения. Макрос отлично работает на начальном примере (фильмы, сериалы, книги). Но вот странность, на других значениях, состоящих из фраз из нескольких слов, макрос сортирует неправильно. Посмотрите, пожалуйста, этот пример. В чем может быть проблема?
Андрей Кольчурин, да, Вы правы, на этом файле отработал некорректно. Исправил, вроде теперь правильно
Код
Sub SENdsfjk2(): Dim Rg1 As Range, kSt&, Tp$
kSt = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:B" & kSt).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range( _
"B2"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase _
:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
For i = kSt To 3 Step -1
If Cells(i, 1) = Cells(i - 1, 1) Then
Tp = Cells(i, 1)
If Rg1 Is Nothing Then Set Rg1 = Union(Cells(i, 1), Cells(i - 1, 1)) Else Set Rg1 = Union(Rg1, Cells(i - 1, 1))
Else
If Not Rg1 Is Nothing Then Rg1.ClearContents: Rg1.Merge: Rg1.Value = Tp: Set Rg1 = Nothing
If i > 3 Then Rows(i).Insert
End If
Next i
If Not Rg1 Is Nothing Then Rg1.ClearContents: Rg1.Merge: Rg1.Value = Tp
End Sub
Sub SENdsfjk3(): Dim Rg1 As Range, kSt&, Tp$
kSt = Cells(Rows.Count, 1).End(xlUp).Row
Tp = "=COUNTIF(R2C1:R" & kSt & "C1,R2C1:R" & kSt & "C1)"
Set Rg1 = Range(Cells(2, 3), Cells(kSt, 3)): Rg1.FormulaR1C1 = Tp
Range("A2:C" & kSt).Sort Key1:=Range("C2"), Order1:=xlDescending, Key2:=Range("A2"), _
Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal, DataOption3:=xlSortNormal
Rg1.Value = Empty: Set Rg1 = Nothing
For i = kSt To 3 Step -1
If Cells(i, 1) = Cells(i - 1, 1) Then
Tp = Cells(i, 1)
If Rg1 Is Nothing Then Set Rg1 = Union(Cells(i, 1), Cells(i - 1, 1)) Else Set Rg1 = Union(Rg1, Cells(i - 1, 1))
Else
If Not Rg1 Is Nothing Then Rg1.ClearContents: Rg1.Merge: Rg1.Value = Tp: Set Rg1 = Nothing
If i > 3 Then Rows(i).Insert
End If
Next i
If Not Rg1 Is Nothing Then Rg1.ClearContents: Rg1.Merge: Rg1.Value = Tp
End Sub
Евгений Смирнов, Спасибо, все хорошо. Но есть весьма важный нюанс - хотелось бы сохранить исходную сортировку во втором столбце. Сейчас фразы во втором столбце сортируются в алфавитном порядке, а нужно чтобы их порядок оставался изначальным.
Евгений Смирнов, Спасибо, с сортировкой все хорошо. Но возник ещё один вопрос - как сделать чтобы при сортировке обрабатывались более двух столбцов? Вот пример таблицы из 5-и столбцов. Хотелось бы чтобы макрос корректно обработал всю таблицу.
Андрей Кольчурин Мне интересно вы меня к чемпионату мира по программированию натаскиваете?(У вас хотелки часто меняются и задание по ночам правите 9 апр 2021 01:59:46) Хочу вас разочаровать я не смогу его выиграть. Вам не понравилось в последнем коде, что я в 3 столбец формулы запихнул, но во всех ваших файлах было 2 столбца данных. Можно сделать по другому добавить столбец туда формулы отсортировать потом удалить его, но подозреваю, что вам потом захочется, чтобы отсортировать 5 или 10 столбцов, а я пока прочитал справку по методу Sort в старом Excel там сортировка только по 3 ключам (3 столбцам), в новом больше поэтому и макрорекордер пишет по разному. Спасибо что подтолкнули меня почитать справку( без конкретного задания не хочется) Иду читать справку.по методу Sort в новом Excel
Евгений Смирнов, Здравствуйте. Да, к сожалению, в процессе решения этой задачи всплыли некоторые нюансы, которых я сам не ожидал. Если сможете доделать этот макрос, то я готов отблагодарить вас финансово. Вот файл с примером реальной таблицы, состоящей из нескольких столбцов. А на втором листе пример желаемого результата.
Проверяйте вроде получается точная копия желаемого результата
Код
Sub SENdsfjk4(): Dim Rg1 As Range, kSt&, Tp$
kSt = Cells(Rows.Count, 1).End(xlUp).Row
Tp = "=COUNTIF(R2C2:R" & kSt & "C2,R2C2:R" & kSt & "C2)": Columns(1).Insert
Set Rg1 = Range(Cells(2, 1), Cells(kSt, 1)): Rg1.FormulaR1C1 = Tp
Range("A2:G" & kSt).Sort Range("A2"), 2, Range("B2"), , 1, , , 0, , 0 ' По убыванию кол-ва в группе
'Range("A2:C" & kSt).Sort Range("A2"), 1, Range("B2"), , 1, , , 0, , 0 ' По возрастанию кол-ва в группе
Columns(1).Delete: Set Rg1 = Nothing
For i = kSt To 3 Step -1
If Cells(i, 1) = Cells(i - 1, 1) Then
Tp = Cells(i, 1)
If Rg1 Is Nothing Then Set Rg1 = Union(Cells(i, 1), Cells(i - 1, 1)) Else Set Rg1 = Union(Rg1, Cells(i - 1, 1))
Else
If Not Rg1 Is Nothing Then Rg1.ClearContents: Rg1.Merge: Rg1.Value = Tp: Set Rg1 = Nothing
If i > 3 Then Rows(i).Insert
End If
Next i
If Not Rg1 Is Nothing Then Rg1.ClearContents: Rg1.Merge: Rg1.Value = Tp
End Sub
Евгений Смирнов, Проверил, всё работает четко, проблем не обнаружил. Как я понял, можно расширять диапазон столбцов до любого количества? https://yadi.sk/i/qqcV6CXGFaQU6A Спасибо) напишите в личку куда вам скинуть копеечку.