Question

我的查询中的数据顺序根据需要显示 - 列A asc，B列asc。

Code       Completion Date Receipt 
P81800A1    09/03/2018   167,000.00 
P81800A1    14/03/2018   178,000.00 
P82080A     12/03/2018   352,500.00 
P83103C1    02/03/2018   570,000.00 
P83103C1    02/03/2018   358,000.00 
P83103C1    02/03/2018   357,500.00 
P83103C1    12/03/2018   340,000.00 
P83103C1    12/03/2018   457,000.00 
P83103C1    13/03/2018   415,000.00 
P83180C1    06/03/2018   645,000.00 
P83180C1    06/03/2018   520,000.00

这意味着如果我在15/03/18刷新数据时完成P81800A1的完成，它将进入上述第2行和第3行之间。

我试图在附图中总结我的目标。我希望VBA条件格式每行基于该行中A的单元格值。即P81800A1行有一种颜色。所有不同的代码都具有相同的颜色。实际颜色并不重要。

我想在VBA中这样做，因此它非常强大。我不想创建任何其他列并将其基于标准条件格式的公式。

Answer 1

所以这不是完美的，而是一个合理的开始。它使用字典来收集唯一代码，并使用字典项计数来生成相关颜色。使用不同的代码应用条件格式规则。

注意：

您可能想要改进随机颜色生成部分（目前范围有限，您可能偶尔会得到非常暗的格式 - 尽管您可以再次运行宏）
使范围选择更加稳健，因为目前起始位置是硬编码的，后来的部分代码也使用此起始位置
对于早期绑定，需要通过VBE＆gt;工具＆gt;引用添加对Microsoft脚本运行时的引用。我已经包含了一个如何使用后期绑定（注释掉）的示例。如果使用后期绑定，则需要为参数和函数返回类型（返回字典）指定Object而不是Dictionary。

假设数据目前在A2开始（表9）

Option Explicit

Public Sub FormatMatchingCodes()

    Dim wb As Workbook
    Dim wsTarget As Worksheet

    Set wb = ThisWorkbook
    Set wsTarget = wb.Worksheets("Sheet9")       'change as appropriate

    Dim lastRow As Long

    Application.ScreenUpdating = False

    lastRow = GetLastRow(wsTarget)

    Dim formatRange As Range

    If Not lastRow <= 2 Then

        Set formatRange = wsTarget.Range("A2:C" & lastRow) 'Excludes header row
    Else
        MsgBox "End row is before start row"
        Exit Sub

    End If

    Dim codeColoursDictionary As Dictionary
    Set codeColoursDictionary = GetDistinctCodeCount(formatRange.Value2)

    wsTarget.Cells.FormatConditions.Delete

    AddFormatting formatRange, codeColoursDictionary

    Application.ScreenUpdating = True

End Sub
Public Function GetDistinctCodeCount(ByVal sourceData As Variant) As Dictionary 'as object if latebound

''LATE binding
'    Dim distinctDict As Object
'    Set distinctDict = CreateObject("Scripting.Dictionary")

''Early binding add reference to VBE > tools > references > Microsoft scripting runtime
    Dim distinctDict As Scripting.Dictionary
    Set distinctDict = New Scripting.Dictionary

    Dim currentCode As Long

    For currentCode = LBound(sourceData, 1) To UBound(sourceData, 1)

        If Not distinctDict.exists(sourceData(currentCode, 1)) Then
            distinctDict.Add sourceData(currentCode, 1), Application.WorksheetFunction.RandBetween(13434828, 17777777) + distinctDict.Count
        End If

    Next currentCode

    Set GetDistinctCodeCount = distinctDict
End Function

Public Function GetLastRow(ByVal wsTarget As Worksheet) As Long

    With wsTarget
           GetLastRow = .Cells(.Rows.Count, "A").End(xlUp).row 'change to column containing last row up to which you want to format
    End With

End Function

Public Sub AddFormatting(ByVal formatRange As Range, ByVal codeColoursDictionary As Dictionary)  'note pass as object if late binding

    Dim key As Variant
    Dim counter As Long

    For Each key In codeColoursDictionary.Keys

        counter = counter + 1

        With formatRange

            .FormatConditions.Add Type:=xlExpression, Formula1:="=$A2=""" & key & """"
            .FormatConditions(counter).StopIfTrue = False

            With .FormatConditions(counter).Interior
                .PatternColorIndex = xlAutomatic
                .Color = codeColoursDictionary(key)
                ' .TintAndShade = 0
            End With

        End With

    Next key

End Sub

运行后的工作表中的数据：

OP的第2版

Option Explicit

Public Sub FormatMatchingCodes2()

    Dim wb As Workbook
    Dim wsTarget As Worksheet

    Set wb = ThisWorkbook
    Set wsTarget = wb.Worksheets("Sheet9")       'change as appropriate

    Dim lastRow As Long

    Application.ScreenUpdating = False

    lastRow = GetLastRow(wsTarget)

    Dim formatRange As Range

    If Not lastRow <= 2 Then

        Set formatRange = wsTarget.Range("A2:G" & lastRow) 'Excludes header row
    Else
        MsgBox "End row is before start row"
        Exit Sub

    End If

    Dim codeColoursDictionary As Dictionary
    Set codeColoursDictionary = GetDistinctCodeCount(formatRange.Value2)

    wsTarget.Cells.FormatConditions.Delete

    AddFormatting formatRange, codeColoursDictionary

    Application.ScreenUpdating = True

End Sub
Public Function GetDistinctCodeCount(ByVal sourceData As Variant) As Dictionary 'as object if latebound

''LATE binding
'    Dim distinctDict As Object
'    Set distinctDict = CreateObject("Scripting.Dictionary")

''Early binding add reference to VBE > tools > references > Microsoft scripting runtime
    Dim distinctDict As Scripting.Dictionary
    Set distinctDict = New Scripting.Dictionary

    Dim currentCode As Long

    For currentCode = LBound(sourceData, 1) To UBound(sourceData, 1)

        If Not distinctDict.exists(sourceData(currentCode, 5)) Then
            distinctDict.Add sourceData(currentCode, 5), Application.WorksheetFunction.RandBetween(13434828, 17777777) + distinctDict.Count
        End If

    Next currentCode

    Set GetDistinctCodeCount = distinctDict
End Function

Public Function GetLastRow(ByVal wsTarget As Worksheet) As Long

    With wsTarget
           GetLastRow = .Cells(.Rows.Count, "E").End(xlUp).row 'change to column containing last row up to which you want to format
    End With

End Function

Public Sub AddFormatting(ByVal formatRange As Range, ByVal codeColoursDictionary As Dictionary)  'note pass as object if late binding

    Dim key As Variant
    Dim counter As Long

    For Each key In codeColoursDictionary.Keys

        counter = counter + 1

        With formatRange

            .FormatConditions.Add Type:=xlExpression, Formula1:="=$E2=""" & key & """"
            .FormatConditions(counter).StopIfTrue = False

            With .FormatConditions(counter).Interior
                .PatternColorIndex = xlAutomatic
                .Color = codeColoursDictionary(key)
                ' .TintAndShade = 0
            End With

        End With

    Next key

End Sub

基于单元格文本值的行的VBA条件格式

1 个答案: