问题解决了。我做了一个额外的数组，最后的循环看起来像这样：

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

这可以通过使用单个字典和自动筛选来完成：

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

请测试下一个更新的代码。它使用了两个字典，应该很快，甚至对于大范围创建联合范围（作为字典键），以立即在代码结束时着色。它创建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

请在测试后发送一些反馈