VBA 基于单元格文本值的行条件格式
VBA conditional formatting of rows based on cell text value
查询中的数据顺序符合要求 - A 列升序，B 列升序。
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
这意味着如果我在 2018 年 3 月 15 日完成 P81800A1，当我刷新数据时，它将在上面的第 2 行和第 3 行之间。
我已尝试在附图中总结我的目标。
我想 VBA 根据该行中 A 的单元格值对每一行进行条件格式化。即 P81800A1 行只有一种颜色。所有不同的代码都具有相同的颜色。实际颜色无关紧要。
我想在 VBA 中完成它，因此它很可靠。我不想创建任何额外的列并将其基于标准条件格式的公式。
所以这不是完美的，而是一个合理的开始。它使用字典来收集唯一代码，并使用字典项目计数随机生成关联的颜色。使用不同的代码应用条件格式规则。
备注：
- 您可能想要改进随机颜色生成部分（目前范围有限，您可能偶尔会得到非常暗的格式 - 尽管您可以再次 运行 宏）
- 使范围选择更加稳健，因为目前起始位置是硬编码的，后面的部分代码也使用这个起始位置
- 需要，对于早期绑定，参考 Microsoft 脚本 运行时间通过 VBE > 工具 > 参考添加。我提供了一个如何使用后期绑定的示例（已注释掉）。如果使用后期绑定，您需要为参数和函数 return 类型指定对象而不是字典（其中字典 returned）。
假设数据目前从 A2 开始 (sheet 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
在运行之后sheet中的数据：
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
查询中的数据顺序符合要求 - A 列升序，B 列升序。
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
这意味着如果我在 2018 年 3 月 15 日完成 P81800A1，当我刷新数据时，它将在上面的第 2 行和第 3 行之间。
我已尝试在附图中总结我的目标。 我想 VBA 根据该行中 A 的单元格值对每一行进行条件格式化。即 P81800A1 行只有一种颜色。所有不同的代码都具有相同的颜色。实际颜色无关紧要。
我想在 VBA 中完成它，因此它很可靠。我不想创建任何额外的列并将其基于标准条件格式的公式。
所以这不是完美的，而是一个合理的开始。它使用字典来收集唯一代码，并使用字典项目计数随机生成关联的颜色。使用不同的代码应用条件格式规则。
备注：
- 您可能想要改进随机颜色生成部分（目前范围有限，您可能偶尔会得到非常暗的格式 - 尽管您可以再次 运行 宏）
- 使范围选择更加稳健，因为目前起始位置是硬编码的，后面的部分代码也使用这个起始位置
- 需要，对于早期绑定，参考 Microsoft 脚本 运行时间通过 VBE > 工具 > 参考添加。我提供了一个如何使用后期绑定的示例（已注释掉）。如果使用后期绑定，您需要为参数和函数 return 类型指定对象而不是字典（其中字典 returned）。
假设数据目前从 A2 开始 (sheet 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
在运行之后sheet中的数据：
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