I have an auto-filtered range of data. The auto filter was created by the following VB code:
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.
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).
Edited per request by @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
Well here is a small Sub
that 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 direction so I can update with the final sort.
EDITTED CODE WITH DOUBLE SORT 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
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: