Страницы: 1
RSS
Сортировка по количеству одинаковых значений в столбце
 
Здравствуйте. Задача скорее всего простая, но решения на форуме не нашел.
В первом столбце - названия групп, во втором - их значения.
https://yadi.sk/i/mrb8GZ2BB8SBSg

Нужно отсортировать строки по размерам групп, то есть по количеству повторяющихся значений в первом столбце.
Должно получиться так:
https://yadi.sk/i/DSoIefszexc8Ig
Изменено: Андрей Кольчурин - 09.04.2021 01:59:46
 
Сортировать в рисунках - задача не из простых :)
Прикрепите пример
 
Вот пример. На первом листе - что имеем изначально, на втором листе - что нужно получить.
На третьем листе - идеальный вариант, который хотелось бы получить - объединение ячеек названий групп и добавление пустых строк между группами.
 
можно в дополнительный столбец записать формулу =СЧЁТЕСЛИ($A$2:$A$10;A2)&" "&A2 протянуть до конца списка  установить фильтр и отсортировать Я-А
Изменено: msi2102 - 09.04.2021 08:26:59
 
Метод 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

Изменено: Евгений Смирнов - 09.04.2021 10:37:34
 
Предлагаю вариант с использованием функции АГРЕГАТ.
Изменено: jakim - 09.04.2021 10:00:08
 
Оказывается макрорекордер в 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
Изменено: Евгений Смирнов - 09.04.2021 15:38:32
 
Цитата
Евгений Смирнов написал:
Оказывается макрорекордер в Excel 2010 пишет кучу лишнего.
нет зависимости от версии.
По вопросам из тем форума, личку не читаю.
 
del
Изменено: buchlotnik - 23.08.2021 15:37:09
Соблюдение правил форума не освобождает от модераторского произвола
 
Можно ещё так:
Изменено: msi2102 - 09.04.2021 13:33:32
 
БМВ
Цитата
нет зависимости от версии.
Сортировка столбца В одного и того же файла записанного макрорекордером
Excel 2002
Код
Sub Макрос1()
' Макрос1 Макрос
' Макрос записан 09.04.2021 (SEN)
    Range("A1:B10").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
End Sub

Excel 2010

Код
Sub Макрос1()
' Макрос1 Макрос
    ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Add Key:=Range("B2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Лист2").Sort
        .SetRange Range("A2:B10")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.RunAutoMacros Which:=xlAutoClose
End Sub

Программный код полностью идиентичен. Можно даже не сравнивать.

Изменено: Евгений Смирнов - 09.04.2021 15:50:56
 
Евгений Смирнов, а нужны ли все параметры, которые выдал макрорекодер в 2002 (и такие динозавры используются?)? Нужна ли строка комментария ' Макрос1 Макрос?
Речь о том, что  при автозаписи в любой версии пишется много чего лишнего. Попробуйте записать значение в ячейку. В 2002 лишних Select'ов не будет?

И я не уверен, что фильтрация, записанная в 2010, нормально отработает в 2002
 
Цитата
Евгений Смирнов написал: Автор еще хотел добавить пустые строки...
Всем большое спасибо за отзывчивость. Я остановился на этом варианте Евгения. Макрос отлично работает на начальном примере (фильмы, сериалы, книги).
Но вот странность, на других значениях, состоящих из фраз из нескольких слов, макрос сортирует неправильно.
Посмотрите, пожалуйста, этот пример. В чем может быть проблема?
Изменено: Андрей Кольчурин - 09.04.2021 17:34:07
 
Андрей Кольчурин, да, Вы правы, на этом файле отработал некорректно.
Исправил, вроде теперь правильно
Код
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
 
Но теперь почему то не сортируется по размеру групп.
https://yadi.sk/i/qkWc32kk_ZKFUg
Изменено: Андрей Кольчурин - 09.04.2021 20:38:28
 
Андрей Кольчурин, попробуйте так (скорее всего, что-то упустил)
 
Не бойтесь совершенства. Вам его не достичь.
 
По убыванию количества в группе
Код
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

По возрастанию в файле

 
Евгений Смирнов, Спасибо, все хорошо. Но есть весьма важный нюанс - хотелось бы сохранить исходную сортировку во втором столбце.
Сейчас фразы во втором столбце сортируются в алфавитном порядке, а нужно чтобы их порядок оставался изначальным.
 
Найдите эти 3 записи в коде и удалите их
Код
 Key3:=Range("B2") Order3:=xlAscending DataOption3:=xlSortNormal
Изменено: Евгений Смирнов - 10.04.2021 08:59:34
 
Евгений Смирнов, Спасибо, с сортировкой все хорошо. Но возник ещё один вопрос - как сделать чтобы при сортировке обрабатывались более двух столбцов?
Вот пример таблицы из 5-и столбцов. Хотелось бы чтобы макрос корректно обработал всю таблицу.
 
Цитата
Андрей Кольчурин написал:
возник ещё один вопрос
с учётом растуще-меняющихся хотелок - чем PQ не устроил?
Соблюдение правил форума не освобождает от модераторского произвола
 
buchlotnik, с PQ к сожалению для меня сложнее разобраться, макросы привычнее.
Изменено: Андрей Кольчурин - 10.04.2021 10:37:26
 
del
Изменено: buchlotnik - 23.08.2021 15:36:53
Соблюдение правил форума не освобождает от модераторского произвола
 
Андрей Кольчурин Мне интересно вы меня к чемпионату мира по программированию натаскиваете?(У вас хотелки часто меняются и задание по ночам правите 9 апр 2021 01:59:46) Хочу вас разочаровать я не смогу его выиграть. Вам не понравилось в последнем коде, что я в 3 столбец формулы запихнул, но во всех ваших файлах было 2 столбца данных. Можно сделать по другому добавить столбец туда формулы отсортировать потом удалить его, но подозреваю, что вам потом захочется, чтобы отсортировать 5 или 10 столбцов, а я пока прочитал справку по методу Sort в старом Excel там сортировка только по 3 ключам (3 столбцам), в новом больше поэтому и макрорекордер пишет по разному. Спасибо что подтолкнули меня почитать справку( без конкретного задания не хочется) Иду читать справку.по методу Sort в новом Excel
Изменено: Евгений Смирнов - 11.04.2021 05:29:46
 
Евгений Смирнов, Здравствуйте. Да, к сожалению, в процессе решения этой задачи всплыли некоторые нюансы, которых я сам не ожидал. Если сможете доделать этот макрос, то я готов отблагодарить вас финансово. Вот файл с примером реальной таблицы, состоящей из нескольких столбцов. А на втором листе пример желаемого результата.
 
Проверяйте вроде получается точная копия желаемого результата
Код
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
Изменено: Евгений Смирнов - 12.04.2021 06:41:51
 
Евгений Смирнов, Проверил, всё работает четко, проблем не обнаружил. Как я понял, можно расширять диапазон столбцов до любого количества? https://yadi.sk/i/qqcV6CXGFaQU6A Спасибо) напишите в личку куда вам скинуть копеечку.
Страницы: 1
Наверх