将填充颜色随机应用于单元格的VBA代码

我对VBA非常陌生，目前我正在从头开始，然而，我正在寻找一种可以自动用随机分配的颜色填充单元格的代码

我需要对一列数据进行编码，并使其在填充值时为每个单元格指定不同的颜色，但相同输入的单元格颜色相同

希望这有意义？例如：

Cat-随机应用黄色

狗-随机应用蓝色

鱼-随机应用绿色

Cat-再次应用黄色

提前感谢。

尝试以下方法

它使用字典收集唯一的“单词”，并使用字典项计数生成关联的颜色。使用不同的“单词”应用条件格式规则

注意事项：

Option Explicit
Public Sub FormatMatchingNames()
    Dim wb As Workbook, wsTarget As Worksheet, lastRow As Long, formatRange As Range
    Set wb = ThisWorkbook
    Set wsTarget = wb.Worksheets("Sheet7")       'change as appropriate

    Application.ScreenUpdating = False
    lastRow = GetLastRow(wsTarget)
    If Not lastRow <= 2 Then
        Set formatRange = wsTarget.Range("A2:A" & lastRow) 'Adjust as required
    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, 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)
            End With
        End With
    Next key
End Sub

您可能希望改进随机颜色生成部分（目前范围有限，有时可能会得到非常暗的格式-尽管您可以再次运行宏）

使范围选择更加可靠，因为当前的起始位置是硬编码的，代码的后续部分也使用此起始位置

对于早期绑定，需要通过VBE>工具>引用添加对Microsoft脚本运行时的引用。我已经包括了一个如何使用后期绑定的示例（注释掉）。如果使用后期绑定，则需要为参数和函数返回类型（其中Dictionary返回）指定Object而不是Dictionary

假设目前数据以A2开头（第7页）

代码：

Option Explicit
Public Sub FormatMatchingNames()
    Dim wb As Workbook, wsTarget As Worksheet, lastRow As Long, formatRange As Range
    Set wb = ThisWorkbook
    Set wsTarget = wb.Worksheets("Sheet7")       'change as appropriate

    Application.ScreenUpdating = False
    lastRow = GetLastRow(wsTarget)
    If Not lastRow <= 2 Then
        Set formatRange = wsTarget.Range("A2:A" & lastRow) 'Adjust as required
    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, 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)
            End With
        End With
    Next key
End Sub

选项显式
公共子格式匹配名称（）
将wb设置为工作簿，将wsTarget设置为工作表，将lastRow设置为长，将formatRange设置为范围
设置wb=ThisWorkbook
设置wsTarget=wb。工作表（“表7”）根据需要进行更改
Application.ScreenUpdating=False
lastRow=GetLastRow（wsTarget）
如果不是lastRow工具>引用>Microsoft脚本运行时
Dim distinct表示为脚本。字典
Set distinctDict=New Scripting.Dictionary
Dim currentCode尽可能长
对于currentCode=LBound（sourceData，1）到UBound（sourceData，1）
如果不存在distinctDict.（源数据（当前代码，1）），则
distinctDict.addsourcedata（currentCode，1），Application.WorksheetFunction.randbween（13434828177777）+distinctDict.Count
如果结束
下一个当前代码
设置GetDistinctCount=DistinctCount
端函数
公共函数GetLastRow（ByVal wsTarget作为工作表）的长度相同
有目标
GetLastRow=.Cells（.Rows.Count，“A”）.End（xlUp）.Row'更改为包含要格式化的最后一行的列
以
端函数
Public Sub AddFormatting（ByVal formatRange作为范围，ByVal codeColoursDictionary作为字典）'如果后期绑定，则注释作为对象传递
变暗键为变型，计数器为长型
对于codeColoursDictionary.keys中的每个键
计数器=计数器+1
具有formatRange
.FormatConditions.Add类型：=Xexpression，公式1:=“=$A2=”“”&键和“”
.FormatConditions（计数器）.StopIfTrue=False
带.FormatConditions（计数器）.内部
.PatternColorIndex=xlAutomatic
.Color=codeColoursDictionary（键）
以
以
下一键
端接头

---

工作表：

Option Explicit
Public Sub FormatMatchingNames()
    Dim wb As Workbook, wsTarget As Worksheet, lastRow As Long, formatRange As Range
    Set wb = ThisWorkbook
    Set wsTarget = wb.Worksheets("Sheet7")       'change as appropriate

    Application.ScreenUpdating = False
    lastRow = GetLastRow(wsTarget)
    If Not lastRow <= 2 Then
        Set formatRange = wsTarget.Range("A2:A" & lastRow) 'Adjust as required
    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, 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)
            End With
        End With
    Next key
End Sub

---

总体目标是什么（或者是这样？），您尝试过什么？可能会有不同的方式。谢谢大家的回复。基本上，我正在建立一个通风系统，列中的每一行都允许我将某个房间分配给某个通风系统。随着系统数量的增加，系统的数量也可能增加，并且它们可能有许多名称。我可以使用条件格式，但在每次添加新系统时更新此格式是无效的。如果VBA代码可以识别，我添加了一个不同的系统，并应用了不同的颜色，这将大大加快速度。非常感谢。简单地说，我的系统引用比显示的要复杂一些，即3.O-1/GF-H//AHU/003 3.O-1/B2-H//AHU/006 3.O-1/B2-H//AHU/005代码是否仍能区分这些引用，或者，它是否仅适用于英语词典中的单词？我确实这样做了，但在实践中这很难使用。我有一个“数据表”工作表，其中我在一个表中列出了我的所有系统参考，并在另一个“计算”工作表上使用下拉菜单将此系统指定给房间。我们是否可以在“数据表”上的系统引用旁边创建另一列，并在其中输入与颜色相关的数字，而不是像您在上述代码中那样使用字典随机生成它们？i、 e.系统参考|颜色代码系统1 | 1系统2 | 2系统3 | 3我正在努力可视化，但如果您想设置预先固定的颜色，只需修改上面的代码，不使用Application.WorksheetFunction.randbween（13434828，17777777）+distinctDict.Count，而是把你预先定义的颜色代码放在这里。但是你必须从你持有系统颜色代码对的那张纸上装入你的字典。我能给你举个例子吗？我对VBA很生疏，这是我目前无法理解的。PS谢谢你到目前为止的帮助。也许明天早上我有更多的时间来仔细考虑。这是很困难的，因为您没有包括一个实际的数据样本来处理。我真的不想继续写解决方案，也不想让你改变需求，但我也不想显得毫无帮助（这句话不只是针对你的！我有点暴躁。对不起。）