基于字典值生成动态颜色，实现Excel行按国家批量着色

假设有含4个国家的10000行数据，需根据Country列（A列）的值为整行着色，且国家数量可能变化，需实现动态适配。Excel文件中的唯一国家值如下：

已完成以下步骤的代码开发：获取唯一国家值、生成对应随机颜色、创建国家与颜色关联的数组，现在需要完成核心循环：根据A列单元格的国家值，匹配对应RGB颜色并设置整行填充色。

现有已实现代码 #

1. 获取唯一国家值 #

data = ActiveSheet.UsedRange.Columns(1).value

Set dict = CreateObject("Scripting.Dictionary")
For rr = 2 To UBound(data)
    dict(data(rr, 1)) = Empty
Next

data = WorksheetFunction.Transpose(dict.Keys())
colors_amount = dict.Count

2. 生成随机颜色 #

Set dict_color = CreateObject("Scripting.Dictionary")
For k = 1 To colors_amount
    myRnd_1 = Int(2 + Rnd * (255 - 0 + 1))
    myRnd_2 = Int(2 + Rnd * (255 - 0 + 1))
    myRnd_3 = Int(2 + Rnd * (255 - 0 + 1))
    color = myRnd_1 & "," & myRnd_2 & "," & myRnd_3
    dict_color.Add Key:=color, Item:=color
Next
data_color = WorksheetFunction.Transpose(dict_color.Keys())

3. 创建国家-颜色关联数组 #

' 需先声明并初始化数组
Dim varArray() As String
ReDim varArray(colors_amount - 1, 1)

For k = 0 To colors_amount - 1
    varArray(k, 0) = data(k + 1, 1)
    varArray(k, 1) = data_color(k + 1, 1)
Next k

核心循环实现：匹配颜色并设置整行填充 #

方案一：用字典直接关联国家与RGB颜色（高效适配大数量数据） #

直接将国家和对应的RGB颜色绑定到同一字典，省去数组中间步骤，代码更简洁高效，适合10000行量级的数据：

' 重置字典，直接关联国家与RGB颜色
Set countryColorDict = CreateObject("Scripting.Dictionary")
' 遍历唯一国家列表分配颜色
For k = 1 To colors_amount
    Dim r As Integer, g As Integer, b As Integer
    ' 生成1-255的随机值，避免过浅颜色影响文字可读性
    r = Int(Rnd * 254) + 1
    g = Int(Rnd * 254) + 1
    b = Int(Rnd * 254) + 1
    countryColorDict(data(k, 1)) = RGB(r, g, b)
Next k

' 遍历数据行设置整行颜色
lastrow = ActiveSheet.UsedRange.Rows.Count
' 关闭屏幕刷新提升大数量数据处理速度
Application.ScreenUpdating = False
For Each Kom In Range("A2:A" & lastrow)
    If countryColorDict.Exists(Kom.Value) Then
        Kom.EntireRow.Interior.Color = countryColorDict(Kom.Value)
    End If
Next Kom
Application.ScreenUpdating = True

方案二：基于现有数组的VLOOKUP匹配实现 #

如果必须使用已创建的varArray数组，可以用Application.VLookup函数完成匹配：

lastrow = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For Each Kom In Range("A2:A" & lastrow)
    Dim colorStr As Variant
    ' 在数组中匹配国家对应的颜色字符串
    colorStr = Application.VLookup(Kom.Value, varArray, 2, False)
    
    If Not IsError(colorStr) Then
        ' 拆分颜色字符串为RGB分量并设置填充色
        Dim rgbParts() As String
        rgbParts = Split(colorStr, ",")
        Kom.EntireRow.Interior.Color = RGB(CInt(rgbParts(0)), CInt(rgbParts(1)), CInt(rgbParts(2)))
    End If
Next Kom
Application.ScreenUpdating = True

内容的提问来源于stack exchange，提问作者Kokopas