Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Сортировка столбцов циклом в каждой строке
 
#1
05.02.2023 09:45:53
Здравствуйте, уважаемые форумчане!
Задача отсортировать ячейки по убыванию отдельно в каждой строке (исключая первую строку заголовков и первый столбец названий)
начиная с ячейки B2
количество используемых ячеек в каждой строке разное
количество строк тоже разное (в разных проектах).

Авторекодером записал сортировку для одной строки.
Код
Option Explicit
Public endRow As Integer

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

endRow = Sheets("исходник").Cells(Rows.Count, 1).End(xlUp).Row

' cортировка одной строки
    ActiveWorkbook.Worksheets("исходник").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("исходник").Sort.SortFields.Add2 Key:=Range("B2:R2" _
        ), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("исходник").Sort
        .SetRange Range("B2:R2")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
Для сортировки остальных строк я думаю использовать цикл с перебором каждой строки до конечной (EndRow),
но с синтаксисом цикла я пока не дружен.
Подскажите пожалуйста структуру цикла для данной задачи!

Заранее спасибо!
 
 
 
#2
05.02.2023 12:27:36
Примерно так можно-
Код
Sub Макрос1()
For Each R In Range([B2], [B2].SpecialCells(xlLastCell)).Rows
  R.Sort R, xlAscending, , , , , , xlNo
Next R
End Sub
Изменено: Апострофф - 05.02.2023 12:31:41
 
 
 
#3
05.02.2023 12:59:14
Апострофф, спасибо за ответ! но у меня работает только в файле примера. Буду смотреть различия между файлом примера и других проектов.
Код лаконичный, но пока не могу адаптировать для себя!
Изменено: CRAFT - 05.02.2023 13:03:56
 
 
 
#4
05.02.2023 13:03:51
CRAFT,
Код
DIM R AS RANGE 'добавьте перед циклом.
 
 
 
#5
05.02.2023 13:14:12
Апострофф, Почему то работает только на листе примера, при дублировании этого листа с данными, на новом уже не работает. Вроде нет привязки к конкретному листу в макросе....
 
 
 
#6
05.02.2023 13:19:57
CRAFT, покажите файл, который "не работает".
 
 
 
#7
05.02.2023 13:30:05
Высылаю тот же самый файл. Сделал дубликат листа "Исходник"
На "исходник" макрос работает
на "исходник (2)" не работает.
от чего это зависит, пока не разобрался.
 
 
 
#8
05.02.2023 16:08:44
Не понял сам - где косяк?
Попробуйте как макрорекордер прописал :oops:
Код
Sub Макрос1()
Dim R As Range
For Each R In Range(Cells(2, 2), Cells(2, 2).SpecialCells(xlLastCell)).Rows
  With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add R, xlSortOnValues, xlDescending, , xlSortNormal
    .SetRange R
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlLeftToRight
    .SortMethod = xlPinYin
    .Apply
  End With
Next R
End Sub
 
 
 
#9
05.02.2023 20:12:08
Апострофф, огромное спасибо!
всё работает как надо!
 
 
 
#10
10.02.2023 22:23:34

Цитата
написал:
Не понял сам - где косяк?
Попробуйте как макрорекордер прописал  
Код
    [URL=#]?[/URL]       1  2  3  4  5  6  7  8  9  10  11  12  13  14  15      Sub   Макрос1()    Dim   R   As   Range    For   Each   R   In   Range(Cells(2, 2), Cells(2, 2).SpecialCells(xlLastCell)).Rows        With   ActiveSheet.Sort          .SortFields.Clear          .SortFields.Add R, xlSortOnValues, xlDescending, , xlSortNormal          .SetRange R          .Header = xlNo          .MatchCase =   False          .Orientation = xlLeftToRight          .SortMethod = xlPinYin          .Apply        End   With    Next   R    End   Sub  
 
Заметил, что макрос в качестве последней ячейки в моей книге принимает значение за 4000 строк, в реальности же таблица не более 500 строк.
Из-за этого макрос выполняется слишком уже медленно (минуты!)
видимо из-за этого

Код
.SpecialCells(xlLastCell)).Rows


нашёл такое решение

Код
'переопределяем рабочий диапазон листа
    With ActiveSheet.UsedRange: End With

Можно ли
Код
SpecialCells(xlLastCell)).Rows
заменить на другую запись типа?
Код
ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
 
 
 
#11
10.02.2023 23:18:18
Код
Sub Sorting()
    Dim R As Range
    Dim LastRow As Long
    Dim LastCol As Long
    Dim CalcStatus As Long
      
    If MsgBox("Отсортировать?", vbQuestion + vbYesNo, "Сортировка") = vbNo Then Exit Sub
      
    Application.ScreenUpdating = False
    CalcStatus = Application.Calculation
    Application.Calculation = xlCalculationManual
      
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        LastCol = .UsedRange.Columns.Count
        For Each R In .Range(.Cells(2, 2), .Cells(LastRow, LastCol)).Rows
            With .Sort
                .SortFields.Clear
                .SortFields.Add R, xlSortOnValues, xlDescending, , xlSortNormal
                .SetRange R
                .Header = xlNo
                .MatchCase = False
                .Orientation = xlLeftToRight
                .SortMethod = xlPinYin
                .Apply
            End With
        Next R
    End With
      
    Application.Calculation = CalcStatus
    Application.ScreenUpdating = True
    MsgBox "Готово", vbInformation, "Сортировка"
End Sub
Изменено: New - 11.02.2023 08:47:08
 
 
 
#12
10.02.2023 23:57:15
New, Большое спасибо!
 
 
 
#13
11.02.2023 00:02:59
CRAFT, забыл удалить из вашего кода SpecialCells(xlLastCell), сейчас обновил свой код выше. Скопируйте его заново
 
 
 
#14
11.02.2023 07:49:09
New, а так не работает!
 
 
 
#15
11.02.2023 08:47:26
)) плохо. Обновил код выше
 
 
 
#16
11.02.2023 09:01:22
New, Теперь заработало!
Спасибо!  
 
 
 
Страницы: 1
Наверх