Excel VBA - 应用自动过滤器并按特定颜色排序

我有一个自动过滤的数据范围。自动过滤器是由以下 VB 代码创建的：

Sub Colour_filter()

Range("A4").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.AutoFilter

End Sub

我想按以下颜色（ Color = RGB(255, 102, 204) ）对“A”列中的值（数据实际上从单元格“A4”开始）进行排序，因此具有该颜色的所有单元格都排序到顶部。

如果可以将额外的代码添加到我现有的代码中，那就太好了？

我的办公室真的很吵，而且我的 VB 也不是最好的。那些一直在笑、在聊天的女士们是加倍困难的。任何帮助都将是缓解压力的天堂！ （附：不要嘲笑女士们，只是我的办公室 95% 都是女性）。

根据 @ScottHoltzman 的请求进行编辑。

我请求的代码构成了较大代码的一部分，这会使事情变得混乱，尽管这是我当前需要的方面的精简版本。

Sub Colour_filter()
' Following code( using conditional formatting) adds highlight to 'excluded' courses based
'on 'course code' cell value matching criteria. Courses codes matching criteria are highlighted
'in 'Pink'; as of 19-Nov-2012 the 'excluded' course codes are
'(BIGTEST, BIGFATCAT).

' <====== CONDITIONAL FORMATTING CODE STARTS HERE  =======>
    Columns("A:A").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""BIGTEST"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
    .Color = 13395711
   End With

Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""BIGFATCAT"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
    .Color = 13395711

End With

' <====== CONDITIONAL FORMATTING CODE ENDS HERE  =======>

' Following code returns column A:A to Font "Tahoma", Size "8"
  Columns("A:A").Select
    With Selection.Font
        .Name = "Tahoma"
        .FontStyle = "Regular"
        .Size = 8
        .ThemeColor = xlThemeColorLight1
        .ThemeFont = xlThemeFontNone

     End With
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = False
    End With

' Following code adds border around all contiguous cells ion range, similar to using keyboard short cut "Ctrl + A".
Range("A4").Select
ActiveCell.CurrentRegion.Select


With Selection
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    End With
With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With



' Following code adds 'Blue' cell colour to all headers in Row 4 start in Cell "A4".

 Range("A4").Select
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    Selection.Font.Bold = True

'<== adds auto-filter to my range of cells ===>

Range("A4").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.AutoFilter

End Sub

那么这里有一个小Sub根据所示图像进行以下排序。大多数值（例如尺寸/范围大小）都是非常静态的，因为这是一个示例。您可以将其改进为动态的。请评论此代码是否朝着正确的方向发展这样我就可以更新最终的排序。

使用双排序键编辑代码

代码： 选项显式

子按颜色排序() 调光范围
将 i 调暗为整数 Dim inputArray 作为变体，colorSortID 作为变体 暗色索引只要长

Set rng = Sheets(1).Range("D2:D13")
colourIndex = Sheets(1).Range("G2").Interior.colorIndex

 ReDim inputArray(1 To 12)
 ReDim colourSortID(1 To 12)

For i = 1 To 12
    inputArray(i) = rng.Cells(i, 1).Interior.colorIndex
    If inputArray(i) = colourIndex Then
        colourSortID(i) = 1
    Else
        colourSortID(i) = 0
    End If
Next i

'--output the array with colourIndexvalues and sorting key values
 Sheets(1).Range("E2").Resize(UBound(inputArray) + 1) = _ 
                   Application.Transpose(inputArray)
 Sheets(1).Range("F2").Resize(UBound(colourSortID) + 1) = _ 
                   Application.Transpose(colourSortID)

 '-sort the rows based on the interior colour
 Application.DisplayAlerts = False
 Set rng = rng.Resize(, 3)

    rng.Sort Key1:=Range("F2"), Order1:=xlDescending, _
    Key2:=Range("E2"), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal

 Application.DisplayAlerts = True

 End Sub

output: