olegvix (Все сообщения пользователя)

Сортировка строк по цвету по определенному условию

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

01.09.2017 10:08:08

добавил все получилось - еще раз благодарю за поддержку !

Код
Set rngFind = rngSort.Find(strIdValue, LookIn:=xlValues, LookAt:=xlWhole)

Изменено: olegvix - 01.09.2017 10:09:03

Перейти

Сортировка строк по цвету по определенному условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

01.09.2017 09:10:30

благодарю iMrTidy за поддержку !

только правда еще одно (пропустил ранее не заметил) - когда самый 1 раз красишь строку ( либо макросом по кнопке либо просто формат по образцу) то выделение строки которую закрасили и сместили потом происходит некорректно а на 2-3-4 раз и далее все нормально идет.

проще в данном примере когда красишь желтым в 8 строке первый раз - выделение должно сместится на 24 строку (куда попал закрашенный желтым диапазон) а туда выделение не попадает
на второй третий раз и далее все нормально с выделением строки - попадает куда надо

Изменено: olegvix - 01.09.2017 09:44:48

Перейти

Сортировка строк по цвету по определенному условию

olegvix Пользователь Сообщений: 39 Регистрация: 10.08.2017	# 31.08.2017 12:02:46 вот так нагляднее будет пример -кнопка добавляет цвет в строку - и строки сортируются Изменено: olegvix - 31.08.2017 12:14:59
	Перейти

Сортировка строк по цвету по определенному условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

31.08.2017 09:51:12

почему никак - вариант iMrTidy выше работает же при выделении любой строки цветом - все сортируется осталось как то сам макрос Sub Сортировка_несколько_цветов ускорить чтоб побыстрее работал на больших диапазонах

Перейти

Сортировка строк по цвету по определенному условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

31.08.2017 08:51:39

пока по кнопке с учетом варианта iMrTidy сделал (выделение исходной строки не слетает)но вопрос остается
- как макрос Sub Сортировка_несколько_цветов по цвету для больших диапазонов сортировку по цветам сделать чтоб не тупило (рассматривается вариант не по кнопке а просто при выделении строки цветом в диапазоне автофильтра)

Код

'макрос1 чтоб выделение изначальной строки (ячейки) после сортировки не слетало
Sub Сортировка_ЦВЕТ()
Dim strIdValue As String
Dim rngFind As Range
Application.ScreenUpdating = False
strIdValue = Range("A" & ActiveCell.Row).Value2
Сортировка_несколько_цветов
Set rngFind = Range("A3:A5003").Find(strIdValue, LookIn:=xlValues)
Range("A" & rngFind.Row & ":BP" & rngFind.Row).Select
Application.ScreenUpdating = True
End Sub

'макрос2 - сама сортировка по цвету
Sub Сортировка_несколько_цветов()
    'нет заливки
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Add Key:=Range( _
        "A3:BP5003"), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'коричневый
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Add(Range( _
        "A3:BP5003"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color _
        = RGB(255, 204, 153)
    With ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'желтый
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Add(Range( _
        "A3:BP5003"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color _
        = RGB(255, 255, 153)
    With ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'зеленый
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Add(Range( _
        "A3:BP5003"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color _
        = RGB(153, 255, 204)
    With ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Изменено: olegvix - 31.08.2017 09:10:04

Перейти

Сортировка строк по цвету по определенному условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

31.08.2017 01:20:55

Благодарю iMrTidy - то что надо ! Единственное одно не учел - на больших диапазонах мой макрос Сортировка_несколько_цветов тупит -
поэтому при изменении цвета строки все работает - но изза макроса Сортировка_несколько_цветов идет задержка обработки
как его для больших диапазонов сортировку по цветам сделать чтоб не тупило ?
диапазон автофильтра использую A3:BP5003

Изменено: olegvix - 31.08.2017 09:07:06

Перейти

Сортировка строк по цвету по определенному условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

30.08.2017 20:45:42

Добрый вечер всем !

Сделал макрос который сортирует в определенной последовательности по цвету
в диапазоне автофильтра.
По кнопке макрос работает как надо.
Вопрос: как сделать так чтобы при закрашивании строки в диапазоне автофильтра макрос срабатывал по условию -
если только полная строка (не ячейка) в диапазоне автофильтра закрашена одним из трех цветов - то срабатывает макрос
и остается выделенной строка которую закрасили изначально (при смещении закрашенной строки вверх) ?
и макрос трехэтажный получился рекодером ...

Код

Sub Сортировка_несколько_цветов()
Application.ScreenUpdating = False
    'нет заливки
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Add Key:=Range( _
        "E4:E100"), SortOn:=xlSortOnCellColor, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'коричневый
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Add(Range( _
        "E4:E100"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color _
        = RGB(255, 204, 153)
    With ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'желтый
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Add(Range( _
        "E4:E100"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color _
        = RGB(255, 255, 153)
    With ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'зеленый
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort.SortFields.Add(Range( _
        "E4:E100"), xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color _
        = RGB(153, 255, 204)
    With ActiveWorkbook.Worksheets("Лист1").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Application.ScreenUpdating = True
End Sub

Перейти

Как прописать в строке макроса символ - любая буква

olegvix Пользователь Сообщений: 39 Регистрация: 10.08.2017	# 23.08.2017 14:56:17 Chr(WorksheetFunction.RandBetween(192, 255)) помогло спасибо Изменено: olegvix - 23.08.2017 14:56:35
	Перейти

Как прописать в строке макроса символ - любая буква

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

23.08.2017 13:44:38

День добрый всем !

Возник вопрос как прописать в строке макроса оператор [Любая буква русского/англ алфавита] (важно чтобы была не цифра)
те 3 символ в слове дб именно буквой

Код

For Each y In Array("10 & Chr(41) & (любая буква - не цифра)", "11 & Chr(41) & (любая буква - не цифра)", "11 & Chr(41) & (любая буква - не цифра)")
 /////////////
Next

Перейти

Перенос строк в ячейках диапазона по условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

23.08.2017 07:16:05

благодарю SAS888 - действительно значительно быстрее работает так сделал

Код

Sub Main()
    Dim x As Range, z: Application.ScreenUpdating = False
    Set x = Range("U4:U" & Cells(Rows.Count, "U").End(xlUp).Row): x.Replace Chr(10), ""
    For Each z In Array("Перенос", "Факт", "Пример", "Значение", "1)Т", "2)Т", "3)Т", "4)Т", "5)Т", "6)Т")
        x.Replace z, Chr(10) & z
    Next
    Rows("4:5003").EntireRow.AutoFit
Application.ScreenUpdating = True
End Sub

Перейти

Перенос строк в ячейках диапазона по условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

22.08.2017 19:38:51

извиняюсь рано радовался при обработке 5000 строк (добавил ячейки) данный скрипт зависает проверил с 21.03 до 21.30 мертво зависает на 30 мин и более - на большие диапазоны не подходит видимо нужны функции или массивом прописывать
Пробовал ранее может так с поправками - скрипт ниже
или как вариант массивом как сделать не знаю знаний не хватает

Код

Function PerenosN(cell As String) As String
Dim iTemp
Dim i As Integer
  iTemp = Split(cell, "Перенос")
    For i = 0 To UBound(iTemp) Step 1
        'For i = 0 To UBound(iTemp)
      'PerenosN = PerenosN & iTemp(i) & "Перенос" & iTemp(i + 1) & "Перенос" & Chr(10)
      PerenosN = PerenosN & iTemp(i) & "Перенос" & Chr(10)
      'PerenosN = PerenosN & "Перенос" & Chr(10)
    Next
End Function
---------------------------------------------------------------------------------------------------------
Sub ПереносПоЗначениям()
Application.ScreenUpdating = False
Dim LastRow As Long, r As Long
LastRow = Cells(Rows.Count, 21).End(xlUp).Row
For r = 4 To LastRow
Cells(r, 21) = PerenosN(Cells(r, 21))
Next
Application.ScreenUpdating = True
End Sub

Изменено: olegvix - 22.08.2017 19:49:28

Перейти

Перенос строк в ячейках диапазона по условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

22.08.2017 18:10:08

спасибо Владимир что откликнулись на проблему извините что не все внятно обьяснил
все вроде замечательно работает и на повторение макроса лишние переносы не дает это +
но одна неприятная ситуация в макросе - почему он лезет во 2 и 3 строку - в 3 прописывает значения во 2 -й меняет ширину строки
вроде ограничили все диапазоном U4 до последней заполненной строки

Перейти

Перенос строк в ячейках диапазона по условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

22.08.2017 14:54:20

Пошел по пути функции без замены и копирования строк как то так
пока перенос строк в ячейке в диапазоне только по одному значению "Перенос"
перенос проходит нормально
но при этом ошибка пошла слово "Перенос" параллельно копируется в конец ячейки при применении макроса - где проблема в коде ?

Код

Function PerenosN(cell As String) As String
Dim iTemp
Dim i As Integer
  iTemp = Split(cell, "Перенос")
    For i = 0 To UBound(iTemp) Step 1
        'For i = 0 To UBound(iTemp)
      'PerenosN = PerenosN & iTemp(i) & "Перенос" & iTemp(i + 1) & "Перенос" & Chr(10)
      PerenosN = PerenosN & iTemp(i) & "Перенос" & Chr(10)
      'PerenosN = PerenosN & "Перенос" & Chr(10)
    Next
End Function
---------------------------------------------------------------------------------------------------------
Sub ПереносПоЗначениям()
Application.ScreenUpdating = False
Dim LastRow As Long, r As Long
LastRow = Cells(Rows.Count, 21).End(xlUp).Row
For r = 4 To LastRow
Cells(r, 21) = PerenosN(Cells(r, 21))
Next
Application.ScreenUpdating = True
End Sub

Изменено: olegvix - 22.08.2017 14:58:03

Перейти

Перенос строк в ячейках диапазона по условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

22.08.2017 11:05:43

не работает этот макрос толком - по факту перенос строки только 1 значение ловит переносит в строке isk = Array("Перенос", "Факт", "Пример", "Значение") - те перенос только на слове "Перенос" - остальное достигается только подбором ширины столбца а переносов по факту нет это видно при изменении ширины столбца

Изменено: olegvix - 22.08.2017 11:14:02

Перейти

Перенос строк в ячейках диапазона по условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

22.08.2017 08:17:37

Как при выполнении этого макроса выделить строку в ячейке до 1-го переноса (чтоб она не терялась при выполнении макроса - сейчас теряется) и вставить в преобразованную ячейку с переносами в самом начале ? Как определить 1-й перенос строки ?

Код

Sub qqq()
Dim i&, y&, x1&, x2&, isk(), arr(), lstr&
Application.ScreenUpdating = False
'isk = Array("Перенос", "Факт", "Пример", "Значение", "1&Chr(41)", "2&Chr(41)", "3&Chr(41)", "4&Chr(41)", "5&Chr(41)", "6&Chr(41)")
isk = Array("Перенос", "Факт", "Пример", "Значение")
lstr = Cells(Rows.Count, 21).End(xlUp).Row
For y = 3 To lstr
    On Error Resume Next
    For i = 0 To 3
       x1 = InStr(Cells(y, 21), isk(i))
       x2 = InStr(Cells(y, 21), isk(i + 1))
       If x2 = x1 Then
            Cells(y, 90) = Cells(y, 90) & isk(i) & Chr(10) & Mid(Cells(y, 21), x1 + Len(isk(i)), 1000)
        Else
            Cells(y, 90) = Cells(y, 90) & isk(i) & Chr(10) & Mid(Cells(y, 21), x1 + Len(isk(i)), x2 - x1 - Len(isk(i)))
       End If
       Cells(y, 90).HorizontalAlignment = xlCenter
    Next
Next y
arr = [CL3].CurrentRegion.Value
[U3].Resize(UBound(arr)) = arr
Columns(90).Clear
Columns(21).ColumnWidth = 63
Rows("3:" & lstr).EntireRow.AutoFit
Application.ScreenUpdating = True
End Sub

Перейти

Перенос строк в ячейках диапазона по условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

21.08.2017 17:27:35

понял как надо благодарю Владимир - единственное что важно почему начальные значения
( в столбце 21 значения \N \N \N \N \N \N либо другой текст в начале строки до первого переноса макросом ) в исходной ячейке столбца 21
пропадают при применении кода можно ли както это поправить
пример приложил

Изменено: olegvix - 22.08.2017 08:08:02

Перейти

Перенос строк в ячейках диапазона по условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

21.08.2017 16:33:37

чето не получилось у меня добавлением

Код
Cells(y, 21).Value = Cells(y, 23).Value Columns(23).Delete

все вкривь и вкось идет
и плюс в столбце 21 значения \N \N \N \N \N \N в начале строки в исходной ячейке столбца 21 пропадают при применении кода
может както массивами можно - а то зависнет код на множестве строк

Код

ub qqq()
Dim i&, y&, x&, isk(), lstr&
Application.ScreenUpdating = False
'isk = Array("Перенос", "Факт", "Пример", "Значение", "1&Chr(41)", "2&Chr(41)", "3&Chr(41)", "4&Chr(41)", "5&Chr(41)", "6&Chr(41)")
isk = Array("Перенос", "Факт", "Пример", "Значение")
lstr = Cells(Rows.Count, 21).End(xlUp).Row
For y = 3 To lstr
    On Error Resume Next
    For i = 0 To 3
       x1 = InStr(Cells(y, 21), isk(i))
       x2 = InStr(Cells(y, 21), isk(i + 1))
       If x2 = x1 Then
            Cells(y, 23) = Cells(y, 23) & Chr(10) & isk(i) & Chr(10) & Mid(Cells(y, 21), x1 + Len(isk(i)), 1000)
        Else
            Cells(y, 23) = Cells(y, 23) & Chr(10) & isk(i) & Chr(10) & Mid(Cells(y, 21), x1 + Len(isk(i)), x2 - x1 - Len(isk(i)))
       End If
       Cells(y, 23).HorizontalAlignment = xlCenter
       Columns(23).ColumnWidth = 65 'задаем ширину копируемого столбца
       Cells(y, 21).Value = Cells(y, 23).Value
       Columns(23).Delete
       
    Next
Next y
Application.ScreenUpdating = True
End Sub

Изменено: olegvix - 21.08.2017 18:18:45

Перейти

Перенос строк в ячейках диапазона по условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

21.08.2017 14:56:02

этот столбец в середине заполненной таблицы - Delete Shift:=xlToLeft не пойдет
я так токо пробую макросы писать на примерах
- но в вашем коде не понимаю где смещение идет как привязать без смещения на замену данных в исходной ячейке

Перейти

Перенос строк в ячейках диапазона по условию

olegvix Пользователь Сообщений: 39 Регистрация: 10.08.2017	# 21.08.2017 14:24:33 такто все правильно - а где в коде смещение прописано понять не могу - offset нет
	Перейти

Перенос строк в ячейках диапазона по условию

olegvix Пользователь Сообщений: 39 Регистрация: 10.08.2017	# 21.08.2017 14:15:00 благодарю Владимир за ответ к сожалению почемуто некорректно работает - смещает в столбец W переделанные значения с переносом (а не заменяет в столбце U) исх данные в ячейке как надо в примере видно
	Перейти

Перенос строк в ячейках диапазона по условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

21.08.2017 13:41:53

понял вроде что вы имеете в виду - но к сожалению видимо я неправильно пример составил - цеплятся надо именно к целым словам по списку - смысла "Перенос" & i здесь нет так верно будет по исходнику

Исходник переделал
Возникла трудность в написании макроса
Диапазон от U4 до последней заполненной строки
По критериям Как макросом произвести перенос строк в диапазоне U4 до последней заполненной строки (планируется до 5000 строк) по принципу - если встречается значение Перенос,Факт,Пример,Значение,1),2),3),4),5),6) в ячейке диапазона - то перенос производится перед этими значениями
& Chr(10) & перенос - но вот как уловить начало значения "Перенос","Факт",",Пример","Значение","1)","2)","3)","4)","5)","6)" в тексте по условию If(перед которыми производится перенос строк) ?
Файл с примером во вложении.

Изменено: olegvix - 21.08.2017 13:55:43

Перейти

Перенос строк в ячейках диапазона по условию

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

21.08.2017 12:25:40

Добрый день всем !

Возникла трудность в написании макроса
Диапазон от U4 до последней заполненной строки
По критериям Как макросом произвести перенос строк в диапазоне U4 до последней заполненной строки (планируется до 5000 строк) по принципу - если встречается значение Перенос1,Перенос2,Перенос3,Перенос4,1),2),3),4),5),6) в ячейке диапазона - то перенос производится перед этими значениями
& Chr(10) & перенос - но вот как уловить начало значения "Перенос1","Перенос2","Перенос3","Перенос4","1)","2)","3)","4)","5)","6)" в тексте по условию If(перед которыми производится перенос строк) ?
Файл с примером во вложении.

Макрос начал делать но как прописать перенос по условию ?

Код

Sub ПереносыТелефон()
With ActiveSheet.UsedRange
    LastRow As Long, r21Range As Range
    'LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
    LastRow = Cells.Find("*", [A1], SearchDirection:=xlPrevious).Row
'Делаем_Переносы_по значениям  21 столбец
Range("U4", Cells(LastRow, 21)).Select
Set r21Range = Intersect(Selection, ActiveSheet.UsedRange)
'Переносы 21 столбец по условиям начала значений
'If как определить здесь перенос по началу значений ?
End With
End Sub

Перейти

Сортировка значений в столбце от мин к макс по части значения

olegvix Пользователь Сообщений: 39 Регистрация: 10.08.2017	# 15.08.2017 08:29:09 Благодарю bedvit - со скоростью проблемы исчезли и заработало как надо !
	Перейти

Сортировка значений в столбце от мин к макс по части значения

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

14.08.2017 22:38:24

скорость устраивает все хорошо сделал так проблема вроде исчезла - но появилась вторая - не сортирует правильно от мин к максимуму по 6-значному коду
вперемешку все получается почему ума не приложу вроде на небольшом диапазоне все нормально было

Код

Sub Сортировка()

Dim R, arr, x As Long
    LastRow = Cells.Find("*", [A1], SearchDirection:=xlPrevious).Row
    'Set R = Range("A4:BP5000")
    Set R = Range(Cells(4, 1), Cells(LastRow, 68))
    If Not R.Worksheet.AutoFilterMode Then R.Offset(-1, 0).AutoFilter 'автофильтр с проверкой включен ли
    arr = R.Resize(, 1).Offset(, 4) '4-это 1-я строка под фильтром
    For x = 1 To UBound(arr): arr(x, 1) = "'" & Right(arr(x, 1), 6) '6-это количество знаков которые хотим получить Right - вправо идем по обрезке
    Next x
    R.Resize(, 1).Offset(, 68) = arr
    R.Resize(, R.Columns.Count + 1).Sort R.Resize(, 1).Offset(, 68), 1, Header:=xlNo '68 - это количество колонок
    R.Resize(, 1).Offset(, 68).ClearContents

End Sub

Изменено: olegvix - 14.08.2017 22:39:39

Перейти

Сортировка значений в столбце от мин к макс по части значения

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

14.08.2017 22:03:48

Большое спасибо bedvit за код - но к сожалению на моем диапазоне не заработал. Причину нашел в том что если задаешь диапазон и ниже заполненных значений в столбце сортировки появляются пустые поля то код смещает заполненный диапазон вниз. Приложил пример и код на реальном диапазоне A4:BP5000.

Код

Sub Сортировка()

Dim R, arr, x As Long
    Set R = Range("A4:BP5000")
    If Not R.Worksheet.AutoFilterMode Then R.Offset(-1, 0).AutoFilter 'автофильтр с проверкой включен ли
    arr = R.Resize(, 1).Offset(, 4) '4-это 1-я строка под фильтром
    For x = 1 To UBound(arr): arr(x, 1) = "'" & Right(arr(x, 1), 6) '6-это количество знаков которые хотим получить Right - вправо идем по обрезке
    Next x
    R.Resize(, 1).Offset(, 68) = arr
    R.Resize(, R.Columns.Count + 1).Sort R.Resize(, 1).Offset(, 68), 1, Header:=xlNo '68 - это количество колонок
    R.Resize(, 1).Offset(, 68).ClearContents

End Sub

Перейти

Сортировка значений в столбце от мин к макс по части значения

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

14.08.2017 15:57:35

так получилось но тот же вопрос остался - проще можно это сделать тк у меня большой диапазон - этот макрос крутится на выполнение минуты две ??

Код

Sub Сортировка()
Application.ScreenUpdating = False
Dim i As Long
Dim iLR As Long
  iLR = Cells(Rows.Count, 2).End(xlUp).Row
    For i = 4 To iLR
'обрезаем 2 знака в начале и копируем в 16 столбец 6-ть знаков
Cells(i, 16) = Mid(Cells(i, 6), 3)
'сбрасываем текущий автофильтр
Set Wsh = ThisWorkbook.ActiveSheet
' Если автофильтр на листе установлен
    If Wsh.AutoFilterMode = True Then
    Wsh.AutoFilterMode = False
    End If
' Если автофильтр на листе ещё не установлен
    If Not Wsh.AutoFilterMode Then
        ' Поставить новый автофильтр
        Wsh.Range(Cells(3, 2), Cells(500, 16)).AutoFilter
    End If
    Set Wsh = Nothing
' Сортировка от минимального к максимальному
ActiveSheet.AutoFilter.Sort.SortFields.Clear
    ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
        Range("P3:P500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveSheet.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
'выравнивание высоты строки
    Rows("4:500").EntireRow.AutoFit
    Next
'удалить 16 столбец
Columns(16).Delete

'сбрасываем текущий автофильтр
Set Wsh = ThisWorkbook.ActiveSheet
' Если автофильтр на листе установлен
    If Wsh.AutoFilterMode = True Then
    Wsh.AutoFilterMode = False
    End If
' Если автофильтр на листе ещё не установлен
    If Not Wsh.AutoFilterMode Then
        ' Поставить новый автофильтр
        Wsh.Range(Cells(3, 2), Cells(500, 15)).AutoFilter
    End If
    Set Wsh = Nothing

Application.ScreenUpdating = True
End Sub

Изменено: olegvix - 14.08.2017 17:19:37

Перейти

Сортировка значений в столбце от мин к макс по части значения

olegvix Пользователь Сообщений: 39 Регистрация: 10.08.2017	# 14.08.2017 13:26:50 сложно получится - вытянуть в отд столбец 6 цифр - растянуть автофильтр на новый столбец - сортировать - удалить столбец с 6 цифр - перестроить автофильтр обратно Как то может проще есть вариант ?
	Перейти

Сортировка значений в столбце от мин к макс по части значения

olegvix

Пользователь

Сообщений: 39 Регистрация: 10.08.2017

14.08.2017 13:16:18

Добрый день всем !

Как справится с проблемой ?
В диапазоне F4:F2000 находятся 8-значные цифровые значения. Нужно отсортировать значения в столбце F только по ПОСЛЕДНИМ 6 (шести) знакам (цифрам) от мин к максимальным значениям в столбце - два первых знака на сортировку не должны влиять. Автофильтр на диапазон B3:O2000

Стандартный макрос сортировки от мин к макс и пример приложил.

Код

Sub Сортировка()
' Сортировка от минимального к максимальному
ActiveSheet.AutoFilter.Sort.SortFields.Clear
    ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _
        Range("F3:F2000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveSheet.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Перейти

Скопировать значения из одного диапазона в другой на листе по условию

olegvix Пользователь Сообщений: 39 Регистрация: 10.08.2017	# 13.08.2017 21:25:28 мда до этого бы точно не додумался - еще раз спасибо за помощь
	Перейти

Скопировать значения из одного диапазона в другой на листе по условию

olegvix Пользователь Сообщений: 39 Регистрация: 10.08.2017	# 13.08.2017 21:05:17 Kuzmich спасибо за поддержку ! - только учусь писать макросы Сейчас сам попробую разобраться с пустыми значениями.
	Перейти