Есть множество группировок, с запросами у каждого запроса есть частота, как можно массово отсортировать каждую группировку отдельно по убыванию включаю главную фразу группировки?
Буду премного благодарен, заранее всем спасибо за помощь.
Доброго времени суток всем!
Есть множество группировок, с запросами у каждого запроса есть частота, как можно массово отсортировать каждую группировку отдельно по убыванию включаю главную фразу группировки?
Буду премного благодарен, заранее всем спасибо за помощь.RedDeni
RedDeni, из Вашего поста и примера понятна только _общая идея_, что Вы хотите получить, но не конкретно какой результат Вы хотите видеть на выходе. Всё то же самое, только отсортированное (по числу запросов в группировке и то же самое внутри группировки? Обязательно ли на том же листе или можно на другом, чистом?
Кстати, нет ли возможности данные преобразовать в намного более операбельную плоскую структуру, т.е. Группировка - Запрос - Меры без всяких группировок?
RedDeni, из Вашего поста и примера понятна только _общая идея_, что Вы хотите получить, но не конкретно какой результат Вы хотите видеть на выходе. Всё то же самое, только отсортированное (по числу запросов в группировке и то же самое внутри группировки? Обязательно ли на том же листе или можно на другом, чистом?
Кстати, нет ли возможности данные преобразовать в намного более операбельную плоскую структуру, т.е. Группировка - Запрос - Меры без всяких группировок?abtextime
Sub MySort() ' Description: сортирует строки внутри подгруппы
Dim fRow&, i& Dim iRow&: iRow = 2 Dim Arr() Do While Cells(iRow, 1) <> "" iRow = iRow + 1 fRow = iRow 'запоминаем строку начала массива ReDim Arr(1 To 4, 1 To 1) For i = 1 To 100 '100 - максимально допустимое количество значений в выгрузке ReDim Preserve Arr(1 To 4, 1 To i) Arr(1, i) = Cells(iRow, 1) 'второй столбец пропускаем, ибо пустой Arr(3, i) = Cells(iRow, 3) Arr(4, i) = Cells(iRow, 4) iRow = iRow + 1 'увеличиваем просматриваемую строку 'если следующая строка 1-го уровня группировки, то выходим из цикла for If Cells(iRow, 1).Rows.OutlineLevel = 1 Then Exit For Next 'заносим отсортированные значение на место старых Cells(fRow, 1).Resize(UBound(Arr, 2), UBound(Arr, 1)) = SortedArray(TransposeArray(Arr), 4) '4 - колонка по которой сортируем Loop End Sub
Function TransposeArray(ByRef SourceArray() As Variant) As Variant ' Для двумерного массива Application.Transpose не работает, поэтому ' Пользовательская функция для транспонирования двумерного массива Dim X1&: X1 = LBound(SourceArray, 1) Dim X2&: X2 = UBound(SourceArray, 1) Dim Y1&: Y1 = LBound(SourceArray, 2) Dim Y2&: Y2 = UBound(SourceArray, 2) Dim TempArray As Variant, i&, j& ReDim TempArray(Y1 To Y2, X1 To X2) For i = X1 To X2 For j = Y1 To Y2 TempArray(j, i) = SourceArray(i, j) Next j Next i TransposeArray = TempArray End Function
Function SortedArray(Massiv As Variant, SortColumn&) 'функция сортировки двумерного массива Dim N&, i&, j& Dim TmpMas1(1 To 4) As Variant Dim TmpMas2(1 To 4) As Variant
On Error Resume Next For i = 1 To UBound(Massiv) Step 1 'просматриваем все строки массива с верхней до нижней границы For j = 1 To 4 TmpMas1(j) = Massiv(i, j) Next j For N = i To UBound(Massiv) 'просматриваем строки массива, начиная с той, значения которой храняться в TmpMas1 If Massiv(N, SortColumn) > TmpMas1(SortColumn) Then 'если значение в массиве больше, чем в переменной то присваиваем TmpMas1 новые, большие значения. Ддля смены направления сортировки изменить знак For j = 1 To 4 TmpMas1(j) = Massiv(N, j) TmpMas2(j) = Massiv(i, j) 'сохраняем в переменных старые значения строки массива Massiv(i, j) = TmpMas1(j) 'и присваиваем этой строке массива новые Massiv(N, j) = TmpMas2(j) 'a строке N присваиваем старые значения из строки i Next j End If Next N Next i SortedArray = Massiv End Function
[/vba]
RedDeni, Если я правильно понял...
[vba]
Код
Sub MySort() ' Description: сортирует строки внутри подгруппы
Dim fRow&, i& Dim iRow&: iRow = 2 Dim Arr() Do While Cells(iRow, 1) <> "" iRow = iRow + 1 fRow = iRow 'запоминаем строку начала массива ReDim Arr(1 To 4, 1 To 1) For i = 1 To 100 '100 - максимально допустимое количество значений в выгрузке ReDim Preserve Arr(1 To 4, 1 To i) Arr(1, i) = Cells(iRow, 1) 'второй столбец пропускаем, ибо пустой Arr(3, i) = Cells(iRow, 3) Arr(4, i) = Cells(iRow, 4) iRow = iRow + 1 'увеличиваем просматриваемую строку 'если следующая строка 1-го уровня группировки, то выходим из цикла for If Cells(iRow, 1).Rows.OutlineLevel = 1 Then Exit For Next 'заносим отсортированные значение на место старых Cells(fRow, 1).Resize(UBound(Arr, 2), UBound(Arr, 1)) = SortedArray(TransposeArray(Arr), 4) '4 - колонка по которой сортируем Loop End Sub
Function TransposeArray(ByRef SourceArray() As Variant) As Variant ' Для двумерного массива Application.Transpose не работает, поэтому ' Пользовательская функция для транспонирования двумерного массива Dim X1&: X1 = LBound(SourceArray, 1) Dim X2&: X2 = UBound(SourceArray, 1) Dim Y1&: Y1 = LBound(SourceArray, 2) Dim Y2&: Y2 = UBound(SourceArray, 2) Dim TempArray As Variant, i&, j& ReDim TempArray(Y1 To Y2, X1 To X2) For i = X1 To X2 For j = Y1 To Y2 TempArray(j, i) = SourceArray(i, j) Next j Next i TransposeArray = TempArray End Function
Function SortedArray(Massiv As Variant, SortColumn&) 'функция сортировки двумерного массива Dim N&, i&, j& Dim TmpMas1(1 To 4) As Variant Dim TmpMas2(1 To 4) As Variant
On Error Resume Next For i = 1 To UBound(Massiv) Step 1 'просматриваем все строки массива с верхней до нижней границы For j = 1 To 4 TmpMas1(j) = Massiv(i, j) Next j For N = i To UBound(Massiv) 'просматриваем строки массива, начиная с той, значения которой храняться в TmpMas1 If Massiv(N, SortColumn) > TmpMas1(SortColumn) Then 'если значение в массиве больше, чем в переменной то присваиваем TmpMas1 новые, большие значения. Ддля смены направления сортировки изменить знак For j = 1 To 4 TmpMas1(j) = Massiv(N, j) TmpMas2(j) = Massiv(i, j) 'сохраняем в переменных старые значения строки массива Massiv(i, j) = TmpMas1(j) 'и присваиваем этой строке массива новые Massiv(N, j) = TmpMas2(j) 'a строке N присваиваем старые значения из строки i Next j End If Next N Next i SortedArray = Massiv End Function
abtextime, В принципе не важно как это будет выглядеть, сами группировки(или не не группировки, просто уже имеется выгрузка из кластеризатора) можно отсортировать по количеству фраз в них, а фразы внутри группировок должно отсортированы от наиболее частотных к низко частотным.
abtextime, В принципе не важно как это будет выглядеть, сами группировки(или не не группировки, просто уже имеется выгрузка из кластеризатора) можно отсортировать по количеству фраз в них, а фразы внутри группировок должно отсортированы от наиболее частотных к низко частотным.RedDeni
RedDeni, если для Вас структура именно с группировками (плюсиками) не является священной коровой, то сделайте плоскую таблицу вида Группировка-Запрос-Частота и в сводной таблице - сортировки. Понимаете, о чем я? Плоская таблица - это самый удобный вид организации первичных данных.
Это разбиение по группировкам (плюсикам) у Вас сейчас как-то автоматизированно получается?
RedDeni, если для Вас структура именно с группировками (плюсиками) не является священной коровой, то сделайте плоскую таблицу вида Группировка-Запрос-Частота и в сводной таблице - сортировки. Понимаете, о чем я? Плоская таблица - это самый удобный вид организации первичных данных.
Это разбиение по группировкам (плюсикам) у Вас сейчас как-то автоматизированно получается?abtextime
RedDeni, сортировка внутри группы вам была дана в Сообщение № 3 а группы excel и сам сортирует (у меня excel2016 на других версиях не проверял), но что бы группы правильно сортировались в вашем файле надо изменить размещение итоговой строки в структуре группировки(см.влож.)
для удобства дописал еще один макросик и подредактировал прошлые(добавил универсальности)
[vba]
Код
Sub SortGroup() 'запускать с этого макроса 'сортировка групп '' Written: 19.06.2018 Dim iRow&, lCol
With ActiveSheet If .FilterMode Then .ShowAllData iRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'последняя заполненная строка lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'последняя видимая колонка с данными If Not .AutoFilterMode Then .Range(.Cells(1, 1), .Cells(iRow, lCol)).AutoFilter 'включаем фильтр With .AutoFilter.Sort .SortFields.Clear .SortFields.Add Key:=Range("B1:B" & iRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With Call SortSubGroup End Sub
Sub SortSubGroup() ' Description: сортирует строки внутри группы '' Written: 18.06.2018 Dim fRow&, i&, j& Dim iRow&: iRow = 2 Dim Arr() Dim maxRow&, maxCol&, SortCol& With ActiveSheet maxRow = WorksheetFunction.Max(.Columns(2)) 'максимальное количество значений в группе maxCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'последняя видимая колонка с данными SortCol = 4 'колонка по которой сортируем строки в группе Do While .Cells(iRow, 1) <> "" iRow = iRow + 1 fRow = iRow 'запоминаем первую строку группы ReDim Arr(1 To maxCol, 1 To 1) For i = 1 To maxRow 'цикл "по строкам" ReDim Preserve Arr(1 To maxCol, 1 To i) For j = 1 To maxCol 'цикл "по колонкам" Arr(j, i) = IIf(IsError(.Cells(iRow, j)), 0, .Cells(iRow, j)) ' есть сроки с ошибками, поэтому добавил бработку ошибок Next j iRow = iRow + 1 'увеличиваем номер просматриваемой строки 'если следующая строка 1-го уровня группировки, то выходим из цикла "по строкам" If .Cells(iRow, 1).Rows.OutlineLevel = 1 Then Exit For Next i 'заносим отсортированные значение на место старых .Cells(fRow, 1).Resize(UBound(Arr, 2), UBound(Arr, 1)) = SortedArray(TransposeArray(Arr), SortCol) Loop End With End Sub
Function TransposeArray(ByRef SourceArray() As Variant) As Variant ' Для двумерного массива Application.Transpose не работает, поэтому ' Пользовательская функция для транспонирования двумерного массива Dim X1&: X1 = LBound(SourceArray, 1) Dim X2&: X2 = UBound(SourceArray, 1) Dim Y1&: Y1 = LBound(SourceArray, 2) Dim Y2&: Y2 = UBound(SourceArray, 2) Dim TempArray As Variant, i&, j& ReDim TempArray(Y1 To Y2, X1 To X2) For i = X1 To X2 For j = Y1 To Y2 TempArray(j, i) = SourceArray(i, j) Next j Next i TransposeArray = TempArray End Function
Function SortedArray(Massiv As Variant, SortColumn&) 'функция сортировки двумерного массива Dim N&, i&, j&, C&, TmpMas1(), TmpMas2() C = UBound(Massiv, 2) ReDim TmpMas1(1 To C) As Variant ReDim TmpMas2(1 To C) As Variant
On Error Resume Next For i = 1 To UBound(Massiv) Step 1 'просматриваем все строки массива с верхней до нижней границы For j = 1 To C TmpMas1(j) = Massiv(i, j) Next j For N = i To UBound(Massiv) 'просматриваем строки массива, начиная с той, значения которой храняться в TmpMas1 If Massiv(N, SortColumn) > TmpMas1(SortColumn) Then 'если значение в массиве больше, чем в переменной то присваиваем TmpMas1 новые, большие значения. Ддля смены направления сортировки изменить знак For j = 1 To C TmpMas1(j) = Massiv(N, j) TmpMas2(j) = Massiv(i, j) 'сохраняем в переменных старые значения строки массива Massiv(i, j) = TmpMas1(j) 'и присваиваем этой строке массива новые Massiv(N, j) = TmpMas2(j) 'a строке N присваиваем старые значения из строки i Next j End If Next N Next i SortedArray = Massiv End Function
[/vba]
RedDeni, сортировка внутри группы вам была дана в Сообщение № 3 а группы excel и сам сортирует (у меня excel2016 на других версиях не проверял), но что бы группы правильно сортировались в вашем файле надо изменить размещение итоговой строки в структуре группировки(см.влож.)
для удобства дописал еще один макросик и подредактировал прошлые(добавил универсальности)
[vba]
Код
Sub SortGroup() 'запускать с этого макроса 'сортировка групп '' Written: 19.06.2018 Dim iRow&, lCol
With ActiveSheet If .FilterMode Then .ShowAllData iRow = .Cells(.Rows.Count, 1).End(xlUp).Row 'последняя заполненная строка lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'последняя видимая колонка с данными If Not .AutoFilterMode Then .Range(.Cells(1, 1), .Cells(iRow, lCol)).AutoFilter 'включаем фильтр With .AutoFilter.Sort .SortFields.Clear .SortFields.Add Key:=Range("B1:B" & iRow), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With Call SortSubGroup End Sub
Sub SortSubGroup() ' Description: сортирует строки внутри группы '' Written: 18.06.2018 Dim fRow&, i&, j& Dim iRow&: iRow = 2 Dim Arr() Dim maxRow&, maxCol&, SortCol& With ActiveSheet maxRow = WorksheetFunction.Max(.Columns(2)) 'максимальное количество значений в группе maxCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'последняя видимая колонка с данными SortCol = 4 'колонка по которой сортируем строки в группе Do While .Cells(iRow, 1) <> "" iRow = iRow + 1 fRow = iRow 'запоминаем первую строку группы ReDim Arr(1 To maxCol, 1 To 1) For i = 1 To maxRow 'цикл "по строкам" ReDim Preserve Arr(1 To maxCol, 1 To i) For j = 1 To maxCol 'цикл "по колонкам" Arr(j, i) = IIf(IsError(.Cells(iRow, j)), 0, .Cells(iRow, j)) ' есть сроки с ошибками, поэтому добавил бработку ошибок Next j iRow = iRow + 1 'увеличиваем номер просматриваемой строки 'если следующая строка 1-го уровня группировки, то выходим из цикла "по строкам" If .Cells(iRow, 1).Rows.OutlineLevel = 1 Then Exit For Next i 'заносим отсортированные значение на место старых .Cells(fRow, 1).Resize(UBound(Arr, 2), UBound(Arr, 1)) = SortedArray(TransposeArray(Arr), SortCol) Loop End With End Sub
Function TransposeArray(ByRef SourceArray() As Variant) As Variant ' Для двумерного массива Application.Transpose не работает, поэтому ' Пользовательская функция для транспонирования двумерного массива Dim X1&: X1 = LBound(SourceArray, 1) Dim X2&: X2 = UBound(SourceArray, 1) Dim Y1&: Y1 = LBound(SourceArray, 2) Dim Y2&: Y2 = UBound(SourceArray, 2) Dim TempArray As Variant, i&, j& ReDim TempArray(Y1 To Y2, X1 To X2) For i = X1 To X2 For j = Y1 To Y2 TempArray(j, i) = SourceArray(i, j) Next j Next i TransposeArray = TempArray End Function
Function SortedArray(Massiv As Variant, SortColumn&) 'функция сортировки двумерного массива Dim N&, i&, j&, C&, TmpMas1(), TmpMas2() C = UBound(Massiv, 2) ReDim TmpMas1(1 To C) As Variant ReDim TmpMas2(1 To C) As Variant
On Error Resume Next For i = 1 To UBound(Massiv) Step 1 'просматриваем все строки массива с верхней до нижней границы For j = 1 To C TmpMas1(j) = Massiv(i, j) Next j For N = i To UBound(Massiv) 'просматриваем строки массива, начиная с той, значения которой храняться в TmpMas1 If Massiv(N, SortColumn) > TmpMas1(SortColumn) Then 'если значение в массиве больше, чем в переменной то присваиваем TmpMas1 новые, большие значения. Ддля смены направления сортировки изменить знак For j = 1 To C TmpMas1(j) = Massiv(N, j) TmpMas2(j) = Massiv(i, j) 'сохраняем в переменных старые значения строки массива Massiv(i, j) = TmpMas1(j) 'и присваиваем этой строке массива новые Massiv(N, j) = TmpMas2(j) 'a строке N присваиваем старые значения из строки i Next j End If Next N Next i SortedArray = Massiv End Function