Как отсортировать отдельные ячейки по цвету текста ячейки

Question

Первое изображение выше - это исходная ситуация, а следующее изображение - результат после Код сортировки vba.

Вопрос: я пробовал код ниже, но не могу понять, как заставить их работать. * * * * * * * * * * * * * * * * * * sh Чтобы переопределить код VBA, чтобы получить результат, как показано на рисунке выше.

Answer 1

Это действительно упражнение в определении диапазона. Поэтому вам нужен действительно хороший метод определения строк и столбцов. В приведенном ниже коде я использую перечисление для этой цели, которое должно быть в верхней части модуля, перед любыми процедурами. Просмотрите значения и настройте их так, как вам нужно, прежде чем запускать код. Также задайте имя вкладки для того, которое присутствует в вашей книге.

Option Explicit

Enum Par                        ' Definition of parameters
                                ' you can change any of the values below

    ParFirstDataRow = 1         ' location of original data
    ParNumRows = 5              ' number of rows

    ParFirstClm = 5             ' 5 = column E, location of original data
    ParSecondClm = 7            ' 7 = column G, location of original data
    ParTempClm = 10             ' Allow macro to use this column temporarily
End Enum

Sub MergeAndSort()
    ' Variatus @STO 19 Jan 2020

    Dim Ws As Worksheet
    Dim Rng As Range

    Set Ws = Worksheets("Sheet1")       ' change tab name to suit
    Application.ScreenUpdating = False

    With Ws
        ' copy first range to temporary column
        Set Rng = .Range(.Cells(ParFirstDataRow, ParFirstClm), _
                         .Cells(ParFirstDataRow + ParNumRows - 1, ParFirstClm))
        Rng.Copy Destination:=.Cells(1, ParTempClm)

        ' copy second range to temporary column
        Set Rng = .Range(.Cells(ParFirstDataRow, ParSecondClm), _
                         .Cells(ParFirstDataRow + ParNumRows - 1, ParSecondClm))
        Rng.Copy Destination:=.Cells(ParNumRows + 1, ParTempClm)

        ' define the combined range to sort
        Set Rng = .Range(.Cells(ParFirstDataRow, ParTempClm), _
                         .Cells(ParNumRows * 2, ParTempClm))

        With .Sort
            With .SortFields
                .Clear
                .Add Key:=Rng.Cells(1), _
                          SortOn:=xlSortOnValues, _
                          Order:=xlAscending, _
                          DataOption:=xlSortTextAsNumbers
            End With
            .SetRange Rng
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        ' move first range from temporary column
        Set Rng = .Range(.Cells(1, ParTempClm), _
                         .Cells(ParFirstDataRow + ParNumRows - 1, ParTempClm))
        Rng.Cut Destination:=.Cells(ParFirstDataRow, ParFirstClm)

        ' move second range from temporary column
        Set Rng = .Range(.Cells(ParNumRows + 1, ParTempClm), _
                         .Cells((ParNumRows * 2), ParTempClm))
        Rng.Cut Destination:=.Cells(ParFirstDataRow, ParSecondClm)
    End With

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Этот код сначала объединит два диапазона в один столбец, отсортирует этот столбец, а затем перенесет верхнюю половину отсортированного колонка возвращается к первому месту, а остальные ко второму.

Answer 2

Точный ответ выкладываю здесь

    ParFirstDataRow = x + 1       ' location of original data
    ParNumRows = 5                ' number of rows
    ParFirstClm = y + 1           ' column , location of original data
    ParSecondClm = y + 3          ' column , location of original data
    ParTempClm = 38 

    Dim Ws As Worksheet
    Dim Rng As Range

    Set Ws = ActiveSheet          ' change tab name to suit
    Application.ScreenUpdating = False

    With Ws
        ' copy first range to temporary column
        Set Rng = .Range(.Cells(ParFirstDataRow, ParFirstClm), _
                         .Cells(ParFirstDataRow + ParNumRows - 1, ParFirstClm))
        Rng.Copy Destination:=.Cells(ParFirstDataRow, ParTempClm)

        ' copy second range to temporary column
        Set Rng = .Range(.Cells(ParFirstDataRow, ParSecondClm), _
                         .Cells(ParFirstDataRow + ParNumRows - 1, ParSecondClm))
        Rng.Copy Destination:=.Cells(ParNumRows + ParFirstDataRow, ParTempClm)

        ' define the combined range to sort
        Set Rng = .Range(.Cells(ParFirstDataRow, ParTempClm), _
                         .Cells(ParNumRows * 2 + ParFirstDataRow - 1, ParTempClm))

        ActiveSheet.Sort.SortFields.Clear
        ActiveSheet.Sort.SortFields.Add(Rng, _
         xlSortOnFontColor, xlDescending, , xlSortNormal).SortOnValue.Color = RGB(255, 0, 0)

        With ActiveWorkbook.ActiveSheet.Sort
         .SetRange Rng
         .Header = xlNo
         .MatchCase = False
         .Orientation = xlTopToBottom
         .SortMethod = xlPinYin
         .Apply
        End With


        ' move first range from temporary column
        Set Rng = .Range(.Cells(ParFirstDataRow, ParTempClm), _
                         .Cells(ParFirstDataRow + ParNumRows - 1, ParTempClm))
        Rng.Cut Destination:=.Cells(ParFirstDataRow, ParFirstClm)

        ' move second range from temporary column
        Set Rng = .Range(.Cells(ParNumRows + ParFirstDataRow, ParTempClm), _
                         .Cells((ParNumRows * 2 + ParFirstDataRow - 1), ParTempClm))
        Rng.Cut Destination:=.Cells(ParFirstDataRow, ParSecondClm)
    End With

    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With