根据字典值使用不同颜色的VBA循环

Question

假设我有1万行，包含4个国家，我想根据国家为整行上色。国家的数量可能会变化，所以我想保持这种动态。

Excel File - Unique Country Values. |国家|| ------- ||瑞典||芬兰||丹麦|| JAPAN |

首先，我用下面的代码做字典来获取唯一的国家值。

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

然后我想为每个国家生成随机的颜色。

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())

现在是时候创建一个包含国家和颜色的数组了。

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

现在是关键部分，制作循环，根据国家为整个行分配颜色我不知道如何根据Kom值获得适当的颜色值，下面描述我想做的

For Each Kom In Range("A2:A" & lastrow)
'Lets Say Kom Value is Japan so I want to take from array particular RGB Color code and put it on entire row
'I want to connect to array and do VLOOKUP how can I do it ?
Next Kom

你有什么想法吗?

Answer 1

请测试下一个更新的代码。它使用两个字典，并且应该是快速的，即使对于大范围，创建联合范围(作为字典键)，在代码末尾立即着色。它创建了RGB颜色:

Sub colorsToDict()
Dim myRnd_1 As Long, myRnd_2 As Long, myRnd_3 As Long
Dim sh As Worksheet, Color As Long, Data, k As Long
Dim dict As Object, dict_color As Object
Set sh = ActiveSheet
Data = sh.UsedRange.Columns(1).Value

'place unique countries in a dictionary as keys and respective range as item
Set dict = CreateObject("Scripting.Dictionary")
For k = 2 To UBound(Data)
If Not dict.Exists(Data(k, 1)) Then
Set dict(Data(k, 1)) = sh.Range("A" & k)
Else
Set dict(Data(k, 1)) = Union(dict(Data(k, 1)), sh.Range("A" & k))
End If
Next

'place colors in the dictionary item, with the same key as in above dict
Set dict_color = CreateObject("Scripting.Dictionary")
For k = 0 To dict.count - 1
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 = RGB(myRnd_1, myRnd_2, myRnd_3)
dict_color.Add key:=dict.keys()(k), Item:=Color
Next

'Place appropriate colors in the specific Union ranges:
For k = 0 To dict.count - 1
Intersect(dict.Items()(k).EntireRow, sh.UsedRange).Interior.Color = dict_color.Items()(k)
Next k

MsgBox "Ready..."
End Sub

请在测试后发送一些反馈

Answer 2

问题解决。我创建了一个额外的数组，最后的循环是这样的:

ReDim varArrayv2(colors_amount - 1, 0)
For kk = 0 To colors_amount - 1
varArrayv2(kk, 0) = varArray(kk, 0)
Next kk

最终循环

For Each Kom In Range("A2:A" & lastrow)
abc = Kom.value
pos = Application.Match(abc, varArrayv2, False)
color_use = varArray(pos - 1, 1)
nr1_przecinek = InStr(1, color_use, ",")
nr2_przecinek = InStr(1 + nr1_przecinek, color_use, ",")
nr2_nawias = InStr(1 + nr1_przecinek, color_use, ")")
Kolor1 = Mid(color_use, 5, nr1_przecinek - 5)
Kolor2 = Mid(color_use, nr1_przecinek + 1, nr2_przecinek - nr1_przecinek - 1)
Kolor3 = Mid(color_use, nr2_przecinek + 1, nr2_nawias - nr2_przecinek - 1)
Kom.EntireRow.Interior.color = RGB(Kolor1, Kolor2, Kolor3)
Next Kom

Answer 3

这可以通过一个字典和使用autofilter来完成:

Sub tgr()

Dim ws As Worksheet:    Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set to correct sheet
Dim rData As Range:     Set rData = ws.UsedRange.Columns(1)

Dim aData As Variant
If rData.Cells.Count = 1 Then
MsgBox "ERROR: No data found in " & rData.Address(External:=True)
Exit Sub
Else
aData = rData.Value
End If

Dim hUnq As Object:   Set hUnq = CreateObject("Scripting.Dictionary")
hUnq.CompareMode = vbTextCompare  'Make dictionary ignore case for matches (example: JAPAN = japan)

'Remove any previous coloring
rData.EntireRow.Interior.Color = xlNone

Dim i As Long
For i = 2 To UBound(aData, 1)   'Start at 2 to skip header
If Not hUnq.Exists(aData(i, 1)) Then  'Found a new unique value
hUnq(aData(i, 1)) = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
With rData
.AutoFilter 1, aData(i, 1)
.Offset(1).Resize(.Rows.Count - 1).EntireRow.Interior.Color = hUnq(aData(i, 1))
.AutoFilter
End With
End If
Next i

End Sub