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

Excel VBA - Apply auto filter and Sort by specific colour

提问by moshjosh

I have an auto-filtered range of data. The auto filter was created by the following VB code:

我有一个自动过滤的数据范围。自动过滤器由以下 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

I would like to sort the values in column "A" (the data actually start from cell "A4") by the following colour ( Color = RGB(255, 102, 204) ) so all the cells with that colour sort to the top.

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

It would be fab if the extra code could be added to my existing code?

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

My office is really noisy and my VB isn't the best. It is doubly hard with laughing, chatting ladies all about. Any help will be stress relief heaven!! (p.s. no poke at the ladies it's just my office is 95% women).

我的办公室真的很吵，我的 VB 也不是最好的。大笑，聊天的女士们要加倍困难。任何帮助都将是缓解压力的天堂！！（ps 不要戳女士们，只是我的办公室是 95% 的女性）。

---

---

Edited per request by @ScottHoltzman.

由@ScottHoltzman 根据请求编辑。

My requested code forms part of a larger code which would confuse matters, although here is a slimmed down version of the aspect I currently need.

我请求的代码构成了一个更大的代码的一部分，这会混淆问题，尽管这里是我目前需要的方面的精简版本。

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

回答by bonCodigo

Well here is a small Subthat does the following sorting as per shown image. Most of the values like dimensions/range sizes are very static since this is a sample. You may improve it to be dynamic. Please comment if this code is going in the right directionso I can update with the final sort.

好吧，这是一个Sub按照显示的图像进行以下排序的小工具。由于这是一个样本，因此大多数值（如尺寸/范围大小）都是非常静态的。您可以将其改进为动态的。请评论此代码是否朝着正确的方向发展，以便我可以使用最终排序进行更新。

EDITTED CODE WITH DOUBLE SORT KYES

使用双排序 KYES 编辑代码

code: Option Explicit

代码：选项显式

Sub sortByColor() Dim rng As Range
Dim i As Integer Dim inputArray As Variant, colourSortID As Variant Dim colourIndex As Long

Sub sortByColor() Dim rng As Range
Dim i As Integer Dim inputArray As Variant, colourSortID As Variant Dim colourIndex As Long

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:

输出：