VBA Loop Using Different Color Based on Dictionary Value-CodePudding

Lets say I have 10 000 rows with 4 countries and I want to color entire row based on Country. Number of countries might change so I want to keep this dynamic.

Excel File - Unique Country Values. | Country | | ------- | | SWEDEN | | FINLAND | | DENMARK | | JAPAN |

Firstly I do dictionary to get unique country values with code below.

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

Then I want to generate random color for each country.

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

Now it is time to create an array which combines country and color.

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

And now crucial part, making loop which assigns color to entire row based on country I have no idea how to get proper color value based on Kom Value, below description what I want to do

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

Do you have some ideas ?

CodePudding user response：

Please, test the next updated code. It uses three dictionaries and should be fast, even for large ranges creating union ranges (as dictionary keys) to be colored at once, at the end of the code. It creates RGB colors:

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, dict_rng As Object

   Set sh = ActiveSheet
   Data = sh.UsedRange.Columns(1).Value

  Set dict = CreateObject("Scripting.Dictionary")
    For k = 2 To UBound(Data)
        dict(Data(k, 1)) = Empty 'place unique countries in a dictionary as keys
    Next
  
  'place colors in the dictionary item, with the same key as 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 the Union ranges of the same country in dictionary items:
 Set dict_rng = CreateObject("Scripting.Dictionary")
 For k = 2 To UBound(Data)
    If Not dict_rng.Exists(Data(k, 1)) Then
        Set dict_rng(Data(k, 1)) = sh.Range("A" & k)
    Else
        Set dict_rng(Data(k, 1)) = Union(dict_rng(Data(k, 1)), sh.Range("A" & k))
    End If
 Next k
 
 'Place colors in the specific Union ranges:
  For k = 0 To dict_rng.count - 1
       dict_rng.Items()(k).EntireRow.Interior.Color = dict_color.Items()(k)
  Next k
  
  MsgBox "Ready..."
End Sub

Please, send some feedback after testing it

CodePudding user response：

Problem solved. I made an extra array and final loop looks like this:

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

Final loop

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

CodePudding user response：

This can be done with a single dictionary and using 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