Здравствуйте! Нужна помощь. Нужен код макроса, чтобы произвести сортировку по алфавиту данных в двух столбцах: сначала по "Наименование изделия", а потом по "Обозначения детали" с учетом сохранения расчетов (ссылок на другие ячейки) и сгруппированных данных. Кто сталкивался с таким. Подскажите, пожалуйста.
Здравствуйте! Нужна помощь. Нужен код макроса, чтобы произвести сортировку по алфавиту данных в двух столбцах: сначала по "Наименование изделия", а потом по "Обозначения детали" с учетом сохранения расчетов (ссылок на другие ячейки) и сгруппированных данных. Кто сталкивался с таким. Подскажите, пожалуйста.Gydvin
Попробуйте так, при условии, что будут заполнены все столбцы "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] Только долгий будет
Попробуйте так, при условии, что будут заполнены все столбцы "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
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"
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"
К сообщению приложен файл: 11_LAST-2.xlsm(34.5 Kb)
Спасибо Вам огромное за старания. Но, к сожалению, хватает сортировки на один раз. Отсортировало все как надо в первый раз. После некорректно выходит.Gydvin
А, что именно некорректно выходит? Попробовал у себя на вашем последнем файле несколько раз, всё корректно, после чего скопировал ещё один амортизатор в конец таблицы, отсортировал правильно. Возможно, Вы перед сортировкой не раскрыли группировку. Попробуйте так [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]
Код
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
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
