如何在单元格文本颜色上排序离散单元格

Question

上图是原图，下图是vba排序代码后的结果。

问题：我尝试了下面的代码，但不知道如何使这些工作。我希望重新编辑这些 vba 代码以使结果如上图所示。

        Dim gp_cell_1 As Range
        Dim gp_cell_2 As Range
        Set gp_cell_1 = ActiveSheet.Range(ActiveSheet.Cells(x + 1, y + 1), ActiveSheet.Cells(x + 5, y + 1))
        Set gp_cell_2 = ActiveSheet.Range(ActiveSheet.Cells(x + 1, y + 3), ActiveSheet.Cells(x + 5, y + 3))

        Set gp_cell = Application.Union(gp_cell_1, gp_cell_2)

        Dim sht As Worksheet
        Dim rngSort As Range

        Set sht = ActiveSheet

        sht.Sort.SortFields.Clear
        sht.Sort.SortFields.Add(gp_cell, _
            xlSortOnCellColor, xlDescending, , _
            xlSortNormal).SortOnValue.Color = RGB(255, 0, 0)
        With sht.Sort
            .SetRange gp_cell
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

Answer 1

我在这里发布确切的答案

    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

Answer 2

这实际上是一个范围定义的练习。因此，您需要一种非常好的定义行和列的方法。在下面的代码中，我为此目的使用了一个枚举，它必须在模块的顶部，在任何过程之前。在运行代码之前，查看这些值并将它们调整为您需要的值。还将选项卡的名称设置为工作簿中的名称。

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

此代码将首先将两个范围合并到一个列中，对该列进行排序，然后将已排序列的上半部分传输回第一个位置，其余部分传输到第二个位置。