Доброго времени суток уважаемые специалисты и просто гуру Excel Не понимаю как реализовать данные вопрос , прошу вашей помощи На листе 1 Таблица На листе 2 список нужно отсортировать по списку(
Доброго времени суток уважаемые специалисты и просто гуру Excel Не понимаю как реализовать данные вопрос , прошу вашей помощи На листе 1 Таблица На листе 2 список нужно отсортировать по списку(Elhust
Sub NewSortTest() Dim keyRange As Variant Dim sortNum As Long Dim d As Long Dim nomer As String
With ActiveWorkbook.Worksheets("Лист2") lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row ReDim keyRange(lLastRow) d = 0 For i = 1 To lLastRow nomer = .Cells(i, 1) keyRange(d) = nomer d = d + 1 Next End With
Application.AddCustomList ListArray:=keyRange sortNum = Application.CustomListCount ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Лист1").Sort.SortFields.Add Key:=Range("A2:A46"), SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:=sortNum, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Лист1").Sort .SetRange Range("A2:C46") .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End Sub
[/vba]
and_evg, Вот работает как часы [vba]
Код
Sub NewSortTest() Dim keyRange As Variant Dim sortNum As Long Dim d As Long Dim nomer As String
With ActiveWorkbook.Worksheets("Лист2") lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row ReDim keyRange(lLastRow) d = 0 For i = 1 To lLastRow nomer = .Cells(i, 1) keyRange(d) = nomer d = d + 1 Next End With
_Boroda_, Доброго времени суток , решил написать сюда же .. Вопрос всё по теме Настраиваемого списка , он может содержать как я выяснил всего 291 значение ... подскажите что делать если надо отсортировать больше... Спасибо
_Boroda_, Доброго времени суток , решил написать сюда же .. Вопрос всё по теме Настраиваемого списка , он может содержать как я выяснил всего 291 значение ... подскажите что делать если надо отсортировать больше... СпасибоElhust
_Boroda_, Тут получается так что задача немного изменилась и теперь выяснилось что значений разное количество , я пришел к выводу что проще разделить массив на подмассивы ну как описал RAN, я тоже думал так сделать только вот теперь встал вопрос как грамотно разделить одномерный массив на несколько массивов по 290 значений .. потом находить это значение и сортировать дальше не трогая то что уже отсортировалось вот
_Boroda_, Тут получается так что задача немного изменилась и теперь выяснилось что значений разное количество , я пришел к выводу что проще разделить массив на подмассивы ну как описал RAN, я тоже думал так сделать только вот теперь встал вопрос как грамотно разделить одномерный массив на несколько массивов по 290 значений .. потом находить это значение и сортировать дальше не трогая то что уже отсортировалось вотElhust
А вот так если? Вообще без настраиваемых списков. Пишем в столбец рядом порядковые номера в соответствии с расположением во втором массиве, сортируем по этому столбцу и потом удаляем его. Все это, конечно же, макросом ======= Переделал немного (на 2 массива разбил). Код и файл перевложил
[vba]
Код
Sub tt() Application.ScreenUpdating = 0 Application.Calculation = xlCalculationManual r1_ = Range("A1").CurrentRegion.Rows.Count c_ = Range("A1").CurrentRegion.Columns.Count ar1 = Range("A2").Resize(r1_ - 1) ar2 = Range("A2").Offset(, c_).Resize(r1_ - 1) With Sheets("Лист2") r11_ = .Range("A" & .Rows.Count).End(3).Row ar11 = .Range("A1").Resize(r1_ - 1) End With Set slov = CreateObject("Scripting.Dictionary") With slov For i = 1 To UBound(ar11) .Item(ar11(i, 1)) = .Count Next i On Error Resume Next For j = 1 To UBound(ar1) ar2(j, 1) = .Item(ar1(j, 1)) Next j On Error GoTo 0 Range("A2").Offset(, c_).Resize(r1_ - 1) = ar2 End With With ActiveSheet.Sort .SortFields.Clear .SortFields.Add Key:=Cells(2, c_ + 1).Resize(r1_ - 1) .SetRange Range("A2").Resize(r1_ - 1, c_ + 1) .Apply End With Columns(c_ + 1).Clear Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = 1 End Sub
[/vba]
А вот так если? Вообще без настраиваемых списков. Пишем в столбец рядом порядковые номера в соответствии с расположением во втором массиве, сортируем по этому столбцу и потом удаляем его. Все это, конечно же, макросом ======= Переделал немного (на 2 массива разбил). Код и файл перевложил
[vba]
Код
Sub tt() Application.ScreenUpdating = 0 Application.Calculation = xlCalculationManual r1_ = Range("A1").CurrentRegion.Rows.Count c_ = Range("A1").CurrentRegion.Columns.Count ar1 = Range("A2").Resize(r1_ - 1) ar2 = Range("A2").Offset(, c_).Resize(r1_ - 1) With Sheets("Лист2") r11_ = .Range("A" & .Rows.Count).End(3).Row ar11 = .Range("A1").Resize(r1_ - 1) End With Set slov = CreateObject("Scripting.Dictionary") With slov For i = 1 To UBound(ar11) .Item(ar11(i, 1)) = .Count Next i On Error Resume Next For j = 1 To UBound(ar1) ar2(j, 1) = .Item(ar1(j, 1)) Next j On Error GoTo 0 Range("A2").Offset(, c_).Resize(r1_ - 1) = ar2 End With With ActiveSheet.Sort .SortFields.Clear .SortFields.Add Key:=Cells(2, c_ + 1).Resize(r1_ - 1) .SetRange Range("A2").Resize(r1_ - 1, c_ + 1) .Apply End With Columns(c_ + 1).Clear Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = 1 End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
я поражен ! ) очень элегантно ) сейчас разберусь ) Спасибо
