excel 基于字典值使用不同颜色的VBA循环

piwo6bdm  于 2022-12-14  发布在  其他
关注(0)|答案(3)|浏览(147)

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 ?

qzwqbdag

qzwqbdag1#

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

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
nr9pn0ug

nr9pn0ug2#

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

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
tzdcorbm

tzdcorbm3#

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

请在测试后发送一些反馈

相关问题