Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Сортировка сгруппированных строк - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сортировка сгруппированных строк (Макросы/Sub)
Сортировка сгруппированных строк
Gydvin Дата: Среда, 29.12.2021, 11:32 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 18
Репутация: 0 ±
Замечаний: 0% ±

Здравствуйте!
Нужна помощь. Нужен код макроса, чтобы произвести сортировку по алфавиту данных в двух столбцах: сначала по "Наименование изделия", а потом по "Обозначения детали" с учетом сохранения расчетов (ссылок на другие ячейки) и сгруппированных данных.
Кто сталкивался с таким. Подскажите, пожалуйста.
К сообщению приложен файл: 11_LAST-_-.xlsm (53.7 Kb)
 
Ответить
СообщениеЗдравствуйте!
Нужна помощь. Нужен код макроса, чтобы произвести сортировку по алфавиту данных в двух столбцах: сначала по "Наименование изделия", а потом по "Обозначения детали" с учетом сохранения расчетов (ссылок на другие ячейки) и сгруппированных данных.
Кто сталкивался с таким. Подскажите, пожалуйста.

Автор - Gydvin
Дата добавления - 29.12.2021 в 11:32
_Igor_61 Дата: Среда, 29.12.2021, 14:26 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 504
Репутация: 90 ±
Замечаний: 0% ±

Excel 2007
Кто сталкивался с таким

Бывало такое на форумах... У Вас в Столбце "Е" который "Обозначение деталей" пусто. Чего хотите?
 
Ответить
Сообщение
Кто сталкивался с таким

Бывало такое на форумах... У Вас в Столбце "Е" который "Обозначение деталей" пусто. Чего хотите?

Автор - _Igor_61
Дата добавления - 29.12.2021 в 14:26
msi2102 Дата: Среда, 29.12.2021, 14:46 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 413
Репутация: 129 ±
Замечаний: 0% ±

Excel 2007
Попробуйте так, при условии, что будут заполнены все столбцы "B-E". Нижняя граница таблицы определяется по последней заполненной ячейки столбца "D". Без сгруппированных данных, время нет разбираться.
[vba]
Код
Sub Макрос2()
Dim arr1 As Variant, n As Long, r As Long, m As Long, s1 As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
r = Cells(Rows.Count, 4).End(xlUp).Row
arr1 = Range("A6:I" & r)
Set al = CreateObject("System.Collections.ArrayList")
For n = 1 To UBound(arr1)
    If Not arr1(n, 2) = "" Then 'And Not arr1(n, 3) = "" Then
        s1 = arr1(n, 2) & arr1(n, 3)
        arr1(n, 9) = s1
        al.Add s1
    Else
        arr1(n, 9) = s1 & arr1(n, 4) & arr1(n, 5)
        al.Add s1 & arr1(n, 4) & arr1(n, 5)
    End If
Next
al.Sort
For n = 1 To UBound(arr1)
    For m = 1 To UBound(arr1)
        If arr1(m, 9) = al.Item(n - 1) Then
            Rows(r + n + 1 & ":" & r + n + 1).Insert Shift:=xlDown
            Rows(m + 5 & ":" & m + 5).Cut Destination:=Rows(r + n & ":" & r + n)
            arr1(m, 9) = ""
            Exit For
        End If
    Next m
Next n
Rows("6:" & r).Delete Shift:=xlUp
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
[/vba]
Только долгий будет
К сообщению приложен файл: 11_LAST-1.xlsm (29.7 Kb)


Сообщение отредактировал msi2102 - Среда, 29.12.2021, 15:28
 
Ответить
СообщениеПопробуйте так, при условии, что будут заполнены все столбцы "B-E". Нижняя граница таблицы определяется по последней заполненной ячейки столбца "D". Без сгруппированных данных, время нет разбираться.
[vba]
Код
Sub Макрос2()
Dim arr1 As Variant, n As Long, r As Long, m As Long, s1 As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
r = Cells(Rows.Count, 4).End(xlUp).Row
arr1 = Range("A6:I" & r)
Set al = CreateObject("System.Collections.ArrayList")
For n = 1 To UBound(arr1)
    If Not arr1(n, 2) = "" Then 'And Not arr1(n, 3) = "" Then
        s1 = arr1(n, 2) & arr1(n, 3)
        arr1(n, 9) = s1
        al.Add s1
    Else
        arr1(n, 9) = s1 & arr1(n, 4) & arr1(n, 5)
        al.Add s1 & arr1(n, 4) & arr1(n, 5)
    End If
Next
al.Sort
For n = 1 To UBound(arr1)
    For m = 1 To UBound(arr1)
        If arr1(m, 9) = al.Item(n - 1) Then
            Rows(r + n + 1 & ":" & r + n + 1).Insert Shift:=xlDown
            Rows(m + 5 & ":" & m + 5).Cut Destination:=Rows(r + n & ":" & r + n)
            arr1(m, 9) = ""
            Exit For
        End If
    Next m
Next n
Rows("6:" & r).Delete Shift:=xlUp
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
[/vba]
Только долгий будет

Автор - msi2102
Дата добавления - 29.12.2021 в 14:46
Gydvin Дата: Среда, 29.12.2021, 16:01 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 18
Репутация: 0 ±
Замечаний: 0% ±

Бывало такое на форумах... У Вас в Столбце "Е" который "Обозначение деталей" пусто. Чего хотите?


Прошу прощения. Колонка "Обозначения изделия".
В колонке "Обозначение детали" неважна сортировка.
 
Ответить
Сообщение
Бывало такое на форумах... У Вас в Столбце "Е" который "Обозначение деталей" пусто. Чего хотите?


Прошу прощения. Колонка "Обозначения изделия".
В колонке "Обозначение детали" неважна сортировка.

Автор - Gydvin
Дата добавления - 29.12.2021 в 16:01
msi2102 Дата: Четверг, 30.12.2021, 07:42 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 413
Репутация: 129 ±
Замечаний: 0% ±

Excel 2007
Ну если
В колонке "Обозначение детали" неважна сортировка

то можно так:
[vba]
Код
Sub Макрос3()
Dim arr1 As Variant, n As Long, r As Long, m As Long, i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
r = Cells(Rows.Count, 4).End(xlUp).Row
arr1 = Range("B6:C" & r)
ReDim Preserve arr1(LBound(arr1) To UBound(arr1), 1 To 4)
Set al = CreateObject("System.Collections.ArrayList")
For n = 1 To UBound(arr1)
    If Not arr1(n, 1) = "" Then 'And Not arr1(n, 3) = "" Then
        arr1(n, 4) = arr1(n, 1) & arr1(n, 2)
        al.Add arr1(n, 1) & arr1(n, 2)
        If Not al.Count = 1 Then arr1(n - i - 1, 3) = i
        i = 0
    Else
    i = i + 1
    End If
Next
arr1(n - i - 1, 3) = i
al.Sort
i = r + 1
For n = 1 To al.Count
    For m = 1 To UBound(arr1)
        If arr1(m, 4) = al.Item(n - 1) Then
            Rows(i & ":" & i + arr1(m, 3)).Insert Shift:=xlDown
            Rows(m + 5 & ":" & m + 5 + arr1(m, 3)).Cut Destination:=Rows(i & ":" & i + arr1(m, 3))
            i = i + arr1(m, 3) + 1
            arr1(m, 3) = "": arr1(m, 4) = ""
            Exit For
        End If
    Next m
Next n
Rows("6:" & r).Delete Shift:=xlUp
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
[/vba]
Объединённые ячейки должны быть в пределах группы, ссылки на формулы тоже сохранятся. Если в формулах есть диапазон, типа: "=СУММ(E8:E15)" то этот диапазон должен быть тоже в пределах группы, если диапазон выходит за пределы группы, нужно заменить на: "=E8+E9+...+E15"

Нижняя граница таблицы определяется по последней заполненной ячейки столбца "D"
К сообщению приложен файл: 11_LAST-2.xlsm (34.5 Kb)
 
Ответить
СообщениеНу если
В колонке "Обозначение детали" неважна сортировка

то можно так:
[vba]
Код
Sub Макрос3()
Dim arr1 As Variant, n As Long, r As Long, m As Long, i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
r = Cells(Rows.Count, 4).End(xlUp).Row
arr1 = Range("B6:C" & r)
ReDim Preserve arr1(LBound(arr1) To UBound(arr1), 1 To 4)
Set al = CreateObject("System.Collections.ArrayList")
For n = 1 To UBound(arr1)
    If Not arr1(n, 1) = "" Then 'And Not arr1(n, 3) = "" Then
        arr1(n, 4) = arr1(n, 1) & arr1(n, 2)
        al.Add arr1(n, 1) & arr1(n, 2)
        If Not al.Count = 1 Then arr1(n - i - 1, 3) = i
        i = 0
    Else
    i = i + 1
    End If
Next
arr1(n - i - 1, 3) = i
al.Sort
i = r + 1
For n = 1 To al.Count
    For m = 1 To UBound(arr1)
        If arr1(m, 4) = al.Item(n - 1) Then
            Rows(i & ":" & i + arr1(m, 3)).Insert Shift:=xlDown
            Rows(m + 5 & ":" & m + 5 + arr1(m, 3)).Cut Destination:=Rows(i & ":" & i + arr1(m, 3))
            i = i + arr1(m, 3) + 1
            arr1(m, 3) = "": arr1(m, 4) = ""
            Exit For
        End If
    Next m
Next n
Rows("6:" & r).Delete Shift:=xlUp
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
[/vba]
Объединённые ячейки должны быть в пределах группы, ссылки на формулы тоже сохранятся. Если в формулах есть диапазон, типа: "=СУММ(E8:E15)" то этот диапазон должен быть тоже в пределах группы, если диапазон выходит за пределы группы, нужно заменить на: "=E8+E9+...+E15"

Нижняя граница таблицы определяется по последней заполненной ячейки столбца "D"

Автор - msi2102
Дата добавления - 30.12.2021 в 07:42
Gydvin Дата: Четверг, 30.12.2021, 10:07 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 18
Репутация: 0 ±
Замечаний: 0% ±

К сообщению приложен файл: 11_LAST-2.xlsm(34.5 Kb)


Спасибо Вам огромное за старания.
Но, к сожалению, хватает сортировки на один раз. Отсортировало все как надо в первый раз. После некорректно выходит.
К сообщению приложен файл: 11_LAST--.xlsm (62.1 Kb)
 
Ответить
Сообщение
К сообщению приложен файл: 11_LAST-2.xlsm(34.5 Kb)


Спасибо Вам огромное за старания.
Но, к сожалению, хватает сортировки на один раз. Отсортировало все как надо в первый раз. После некорректно выходит.

Автор - Gydvin
Дата добавления - 30.12.2021 в 10:07
msi2102 Дата: Четверг, 30.12.2021, 10:36 | Сообщение № 7
Группа: Проверенные
Ранг: Обитатель
Сообщений: 413
Репутация: 129 ±
Замечаний: 0% ±

Excel 2007
После некорректно выходит

А, что именно некорректно выходит? Попробовал у себя на вашем последнем файле несколько раз, всё корректно, после чего скопировал ещё один амортизатор в конец таблицы, отсортировал правильно.
Возможно, Вы перед сортировкой не раскрыли группировку. Попробуйте так
[vba]
Код
Sub Макрос3()
Dim arr1 As Variant, n As Long, r As Long, m As Long, i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
r = Cells(Rows.Count, 4).End(xlUp).Row
arr1 = Range("B6:C" & r)
ReDim Preserve arr1(LBound(arr1) To UBound(arr1), 1 To 4)
Set al = CreateObject("System.Collections.ArrayList")
For n = 1 To UBound(arr1)
    If Not arr1(n, 1) = "" Then 'And Not arr1(n, 3) = "" Then
        arr1(n, 4) = arr1(n, 1) & arr1(n, 2)
        al.Add arr1(n, 1) & arr1(n, 2)
        If Not al.Count = 1 Then arr1(n - i - 1, 3) = i
        i = 0
    Else
    i = i + 1
    End If
Next
arr1(n - i - 1, 3) = i
al.Sort
i = r + 1
For n = 1 To al.Count
    For m = 1 To UBound(arr1)
        If arr1(m, 4) = al.Item(n - 1) Then
            Rows(i & ":" & i + arr1(m, 3)).Insert Shift:=xlDown
            Rows(m + 5 & ":" & m + 5 + arr1(m, 3)).Cut Destination:=Rows(i & ":" & i + arr1(m, 3))
            i = i + arr1(m, 3) + 1
            arr1(m, 3) = "": arr1(m, 4) = ""
            Exit For
        End If
    Next m
Next n
Rows("6:" & r).Delete Shift:=xlUp
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
[/vba]
К сообщению приложен файл: 5172240.xlsm (34.9 Kb)


Сообщение отредактировал msi2102 - Четверг, 30.12.2021, 10:36
 
Ответить
Сообщение
После некорректно выходит

А, что именно некорректно выходит? Попробовал у себя на вашем последнем файле несколько раз, всё корректно, после чего скопировал ещё один амортизатор в конец таблицы, отсортировал правильно.
Возможно, Вы перед сортировкой не раскрыли группировку. Попробуйте так
[vba]
Код
Sub Макрос3()
Dim arr1 As Variant, n As Long, r As Long, m As Long, i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
r = Cells(Rows.Count, 4).End(xlUp).Row
arr1 = Range("B6:C" & r)
ReDim Preserve arr1(LBound(arr1) To UBound(arr1), 1 To 4)
Set al = CreateObject("System.Collections.ArrayList")
For n = 1 To UBound(arr1)
    If Not arr1(n, 1) = "" Then 'And Not arr1(n, 3) = "" Then
        arr1(n, 4) = arr1(n, 1) & arr1(n, 2)
        al.Add arr1(n, 1) & arr1(n, 2)
        If Not al.Count = 1 Then arr1(n - i - 1, 3) = i
        i = 0
    Else
    i = i + 1
    End If
Next
arr1(n - i - 1, 3) = i
al.Sort
i = r + 1
For n = 1 To al.Count
    For m = 1 To UBound(arr1)
        If arr1(m, 4) = al.Item(n - 1) Then
            Rows(i & ":" & i + arr1(m, 3)).Insert Shift:=xlDown
            Rows(m + 5 & ":" & m + 5 + arr1(m, 3)).Cut Destination:=Rows(i & ":" & i + arr1(m, 3))
            i = i + arr1(m, 3) + 1
            arr1(m, 3) = "": arr1(m, 4) = ""
            Exit For
        End If
    Next m
Next n
Rows("6:" & r).Delete Shift:=xlUp
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub
[/vba]

Автор - msi2102
Дата добавления - 30.12.2021 в 10:36
Gydvin Дата: Четверг, 30.12.2021, 14:22 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 18
Репутация: 0 ±
Замечаний: 0% ±

Возможно, Вы перед сортировкой не раскрыли группировку


Да. Не раскрыл.
Спасибо Вам за помощь. hands
 
Ответить
Сообщение
Возможно, Вы перед сортировкой не раскрыли группировку


Да. Не раскрыл.
Спасибо Вам за помощь. hands

Автор - Gydvin
Дата добавления - 30.12.2021 в 14:22
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сортировка сгруппированных строк (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!