Добрый день . При срабатывании макроса по поиску уникальных значений в массиве Range("J19:J22222") и копировании результата в столбец "Р" не могу отсортировать результат в столбце Р от А до Я. Прошу вашей помощи.
[vba]
Код
Sub Уникальные() Application.ScreenUpdating = False 'отключаем обновление экрана Application.Calculation = xlCalculationManual 'Отключаем автопересчет формул Application.EnableEvents = False 'Отключаем отслеживание событий ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False 'Отключаем разбиение на печатные страницы Dim myRange As Range, myCell As Range, myCollection As New Collection, _ myElement As Variant, i As Long Set myRange = Range("J19:J22222") On Error Resume Next For Each myCell In myRange myCollection.Add CStr(myCell.Value), CStr(myCell.Value) Next myCell On Error GoTo 0 For Each myElement In myCollection i = i + 1 Cells(i, 16) = myElement Next myElement Columns("P:P").Select
' закрыть Макрос Workbooks("макрос.xlsm").Close SaveChanges:=False Application.ScreenUpdating = True 'Возвращаем обновление экрана Application.Calculation = xlCalculationAutomatic 'Возвращаем автопересчет формул Application.EnableEvents = True 'Включаем отслеживание событий End Sub
[/vba]
Добрый день . При срабатывании макроса по поиску уникальных значений в массиве Range("J19:J22222") и копировании результата в столбец "Р" не могу отсортировать результат в столбце Р от А до Я. Прошу вашей помощи.
[vba]
Код
Sub Уникальные() Application.ScreenUpdating = False 'отключаем обновление экрана Application.Calculation = xlCalculationManual 'Отключаем автопересчет формул Application.EnableEvents = False 'Отключаем отслеживание событий ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False 'Отключаем разбиение на печатные страницы Dim myRange As Range, myCell As Range, myCollection As New Collection, _ myElement As Variant, i As Long Set myRange = Range("J19:J22222") On Error Resume Next For Each myCell In myRange myCollection.Add CStr(myCell.Value), CStr(myCell.Value) Next myCell On Error GoTo 0 For Each myElement In myCollection i = i + 1 Cells(i, 16) = myElement Next myElement Columns("P:P").Select
' закрыть Макрос Workbooks("макрос.xlsm").Close SaveChanges:=False Application.ScreenUpdating = True 'Возвращаем обновление экрана Application.Calculation = xlCalculationAutomatic 'Возвращаем автопересчет формул Application.EnableEvents = True 'Включаем отслеживание событий End Sub
Sub UnicSortColumn() Set r = Range("$J$19:$J$22222") a = r.Value r.RemoveDuplicates Columns:=1, Header:=xlNo r.Copy Range("P1").Resize(UBound(a), 1) r.Value = a With r.Parent.Sort .SortFields.Clear .SortFields.Add Key:=Range("P1") .SetRange Range("P1").Resize(UBound(a), 1) .Header = xlNo .Apply End With End Sub
[/vba]
[vba]
Код
Sub UnicSortColumn() Set r = Range("$J$19:$J$22222") a = r.Value r.RemoveDuplicates Columns:=1, Header:=xlNo r.Copy Range("P1").Resize(UBound(a), 1) r.Value = a With r.Parent.Sort .SortFields.Clear .SortFields.Add Key:=Range("P1") .SetRange Range("P1").Resize(UBound(a), 1) .Header = xlNo .Apply End With End Sub
Спасибо. Этот код полностью заменяет мой, т.е. и ищет уникальные и сортирует результат.
Только в столбце J часть символов из Times New Roman 12 перевелись в Calibri 11, и границы таблицы пропали с таким правилом: количество скопированных ячеек из J в P начиная от первой заполненной ячейки ниже J19 остается в Times New Roman 12, а все что ниже - в Calibri 11 и без рамки (J24).
Спасибо. Этот код полностью заменяет мой, т.е. и ищет уникальные и сортирует результат.
Только в столбце J часть символов из Times New Roman 12 перевелись в Calibri 11, и границы таблицы пропали с таким правилом: количество скопированных ячеек из J в P начиная от первой заполненной ячейки ниже J19 остается в Times New Roman 12, а все что ниже - в Calibri 11 и без рамки (J24).timo64uk