Страницы: 1
RSS
Автоматическая многоуровневая сортировка
 
Помогите пожалуйста написать макрос для многоуровневой сортировки.
Допустим, имеется документ excel уже отсортированный сперва по адресу, а затем по цвету ячеек, данный документ формируется из программы написанной на delphi из трех файлов. Зелёные ячейки в верху, затем жёлтые и в конце красные, диапазон [B9:N9] и до конца документа.

Нужно после изменения цвета строки диапазона:
- Переместить её в соответствующий цвет
- И отсортировать по адресу

С макросами дело не имел никогда.
Изменено: vikttur - 10.01.2022 21:38:19
 
Цитата
Юрий Родионов написал: Переместить её в соответствующий цвет
Перемещайте в синий, т.к. он не зеленый не желтый и не красный.

Цитата
отсортировать по адресу
Без проблем, только укажите номер индекса почтового отделения где находится адрес.

Цитата
формируется из программы написанной на delphi из трех файлов
А вот это уже совсем зря. Дельфину как минимум 5 файлов нужно. Вы этого не знали?  :)
Кусочек файла с пояснениями покажите, иначе будем продолжать искать соответствующий цвет и индекс почтового отделения.
 
Вот пример файла
Допустим я внёс изменения в ячейках [I56] и [J56] и окрасил их в зелёный. Так мне надо чтобы он встал на 26 строку, как я только изменил цвет
Изменено: vikttur - 10.01.2022 21:38:42
 
Юрий Родионов,  а есть логика установки цвета? или вы просто произвольно ее выбираете?
а еще не понятно как отсортировано по адресу так как если сортировать по адресу будет совсем подругому
Изменено: Mershik - 10.01.2022 21:14:43
Не бойтесь совершенства. Вам его не достичь.
 
Да, логика есть это делает программа на delphi. Вот она мне выдала отчёт
Сортировалось всё в delphi
 
Цитата
Юрий Родионов написал:
Допустим я внёс изменения в ячейках [I56] и [J56] и окрасил их в зелёный. Так мне надо чтобы он встал на 26 строку
почему именно в 26?? а не в 50?
поймите не понятна логика, удостойте нас своими разъяснениями почему именно так а видимо разъяснение "делает другая программа..." тогда в ней  меняйте на зеленый  цвет  ифбудет сортировать как вам нужно, а макросу нужно написать что и когда делать.
Изменено: Mershik - 10.01.2022 21:19:44
Не бойтесь совершенства. Вам его не достичь.
 
Потому что когда оператор заносит с отчета руками у него в базе открыта вся улица и скакать не очень удобно из-за одного адреса
Я вижу это так:
после того как я изменил цвет, должна сработать сортировка сначала по цвету ячеек, а потом по столбцу "В" всего документа.

Хорошо как отловить что я изменил цвет ячеек?

https://www.programmersforum.ru/showthread.php?t=341526]Вот ссылка на мою тему по delphi
Програму писал сам
 
Юрий Родионов,  это очень сложно  не нужно) лучше запускать макрос с кнопки...
Код
Sub mrshkei()
Dim i As Long, n As Long, k As Long, lr As Long, col As New Collection, sh As Worksheet, sh2 As Worksheet, j As Long, j2 As Long
Set sh = ActiveSheet
Application.ScreenUpdating = False
k = 7 'начало строк с данными
lr = Cells(Rows.Count, 2).End(xlUp).Row 'посл. строка
For i = k To lr
    On Error Resume Next
    col.Add sh.Cells(i, 2).Interior.ColorIndex, CStr(sh.Cells(i, 2).Interior.ColorIndex)
Next i
Sheets.Add
With ActiveSheet
Set sh2 = ActiveSheet
    .Name = Replace(Date, "-", "-")
j = 1

For n = 1 To col.Count
j2 = j
    For i = k To lr
        If sh.Cells(i, 2).Interior.ColorIndex = CDbl(col(n)) Then
        sh.Range(sh.Cells(i, 2), sh.Cells(i, 14)).Copy Destination:=.Cells(j, 1)
        j = j + 1
        End If
    Next i
    
        '.Range(.Cells(j2, 1), .Cells(j - 1, 13)).Select
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add2 Key:=Range( _
        "A" & j2 & ":A" & j - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A" & j2 & ":M" & j - 1)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Next n
sh.Activate
.Range("A1:M" & j - 1).Copy
sh.Cells(k, 2).Select
ActiveSheet.Paste
End With
Application.DisplayAlerts = False
sh2.Delete
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


Цитата
Юрий Родионов написал: С макросами дело не имел никогда.
разбирайтесь)
Изменено: Mershik - 10.01.2022 22:11:39
Не бойтесь совершенства. Вам его не достичь.
 
Mershik Спасибо, буду разбираться
 
Вот что получилось, код размещен в модуле рабочего листа
Код
Dim myColor
Dim myAddress
Dim i
Private Sub ChangeColor()

If Range(myAddress).Interior.ColorIndex = myColor Then Exit Sub
i = UsedRange.Rows.Count + 1
Range(Cells(7, 2), Cells(i, 14)).Select
    ActiveWorkbook.Worksheets("сводный").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("сводный").Sort.SortFields.Add Key:=Range("B7"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("сводный").Sort
        .SetRange Range(Cells(7, 2), Cells(i, 14))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Range(Cells(7, 2), Cells(i, 14)).Select
    ActiveWorkbook.Worksheets("сводный").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("сводный").Sort.SortFields.Add(Range(Cells(7, 2), Cells(i, 2)), _
        xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(0, 255, 0)
    ActiveWorkbook.Worksheets("сводный").Sort.SortFields.Add(Range(Cells(7, 2), Cells(i, 2)), _
        xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0, 0)
    With ActiveWorkbook.Worksheets("сводный").Sort
        .SetRange Range(Cells(7, 2), Cells(i, 14))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If myColor = "" Then myColor = ActiveCell.Interior.ColorIndex
If myAddress = "" Then myAddress = ActiveCell.Address
Call ChangeColor
myColor = ActiveCell.Interior.ColorIndex
myAddress = ActiveCell.Address

End Sub
У меня остался только один вопрос, а как остаться на этой же строке  
Изменено: Юрий Родионов - 11.01.2022 01:30:38
 
Цитата
написал:
как остаться на этой же строке  
Код
Dim myColor
Dim myAddress
Dim i
Private Sub ChangeColor()
 
If Range(myAddress).Interior.ColorIndex = myColor Then Exit Sub
i = UsedRange.Rows.Count + 1

Dim backSelectRange As Range
Set backSelectRange = Selection

Application.EnableEvents = False
Range(Cells(7, 2), Cells(i, 14)).Select
    ActiveWorkbook.Worksheets("сводный").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("сводный").Sort.SortFields.Add Key:=Range("B7"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("сводный").Sort
        .SetRange Range(Cells(7, 2), Cells(i, 14))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
Range(Cells(7, 2), Cells(i, 14)).Select
    ActiveWorkbook.Worksheets("сводный").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("сводный").Sort.SortFields.Add(Range(Cells(7, 2), Cells(i, 2)), _
        xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(0, 255, 0)
    ActiveWorkbook.Worksheets("сводный").Sort.SortFields.Add(Range(Cells(7, 2), Cells(i, 2)), _
        xlSortOnCellColor, xlAscending, , xlSortNormal).SortOnValue.Color = RGB(255, 0, 0)
    With ActiveWorkbook.Worksheets("сводный").Sort
        .SetRange Range(Cells(7, 2), Cells(i, 14))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
backSelectRange.Select
Application.EnableEvents = True
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
If myColor = "" Then myColor = ActiveCell.Interior.ColorIndex
If myAddress = "" Then myAddress = ActiveCell.Address
Call ChangeColor
myColor = ActiveCell.Interior.ColorIndex
myAddress = ActiveCell.Address
 
End Sub

 
МатросНаЗебре Спасибо огромное, вот теперь всё как я и хотел.
Тему можно закрывать
Страницы: 1
Наверх