Question

我对VBA还是很陌生，但是我现在是从零开始，但是，我一直在寻找一种代码，该代码可以使用随机分配的颜色自动填充单元格。

我需要编写代码以应用于一列数据，并让它在填充值时为每个单元格提供不同的颜色，但具有相同条目的颜色单元格则相同...

希望这有意义吗？一个例子是：

猫-随机应用黄色
狗-随机应用蓝色
鱼-随机应用绿色
猫-再次应用黄色。

谢谢。

Answer 1

尝试以下操作。

它使用字典来收集唯一的“单词”，并在字典项数之间插入以生成关联的颜色。条件格式设置规则使用不同的“单词”来应用

注释：

您可能需要改进随机颜色生成部分（目前范围有限，并且有时可能会获得非常暗的格式-尽管您可以再次运行宏）
使范围选择更加稳健，因为当前位置已经硬编码了起始位置，后来的代码部分也使用了该起始位置
对于早期绑定，需要通过VBE>“工具”>“参考”添加对Microsoft脚本运行时的引用。我提供了一个有关如何使用后期绑定（注释掉）的示例。如果使用后期绑定，则需要为参数和函数返回类型（返回字典的位置）指定对象而不是字典。
假设当前数据从A2开始（第7页）

代码：

Option Explicit
Public Sub FormatMatchingNames()
    Dim wb As Workbook, wsTarget As Worksheet, lastRow As Long, formatRange As Range
    Set wb = ThisWorkbook
    Set wsTarget = wb.Worksheets("Sheet7")       'change as appropriate

    Application.ScreenUpdating = False
    lastRow = GetLastRow(wsTarget)
    If Not lastRow <= 2 Then
        Set formatRange = wsTarget.Range("A2:A" & lastRow) 'Adjust as required
    Else
        MsgBox "End row is before start row"
        Exit Sub
    End If

    Dim codeColoursDictionary As Dictionary

    Set codeColoursDictionary = GetDistinctCodeCount(formatRange.Value2)
    wsTarget.Cells.FormatConditions.Delete
    AddFormatting formatRange, codeColoursDictionary

    Application.ScreenUpdating = True
End Sub

Public Function GetDistinctCodeCount(ByVal sourceData As Variant) As Dictionary 'as object if latebound
''LATE binding
'    Dim distinctDict As Object
'    Set distinctDict = CreateObject("Scripting.Dictionary")

''Early binding add reference to VBE > tools > references > Microsoft scripting runtime
    Dim distinctDict As Scripting.Dictionary
    Set distinctDict = New Scripting.Dictionary

    Dim currentCode As Long

    For currentCode = LBound(sourceData, 1) To UBound(sourceData, 1)
        If Not distinctDict.Exists(sourceData(currentCode, 1)) Then
            distinctDict.Add sourceData(currentCode, 1), Application.WorksheetFunction.RandBetween(13434828, 17777777) + distinctDict.Count
        End If
    Next currentCode

    Set GetDistinctCodeCount = distinctDict
End Function

Public Function GetLastRow(ByVal wsTarget As Worksheet) As Long
    With wsTarget
           GetLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'change to column containing last row up to which you want to format
    End With
End Function

Public Sub AddFormatting(ByVal formatRange As Range, ByVal codeColoursDictionary As Dictionary)  'note pass as object if late binding
    Dim key As Variant, counter As Long
    For Each key In codeColoursDictionary.keys
        counter = counter + 1
        With formatRange
            .FormatConditions.Add Type:=xlExpression, Formula1:="=$A2=""" & key & """"
            .FormatConditions(counter).StopIfTrue = False
            With .FormatConditions(counter).Interior
                .PatternColorIndex = xlAutomatic
                .Color = codeColoursDictionary(key)
            End With
        End With
    Next key
End Sub

表格：

VBA代码可将填充颜色随机应用于单元格

1 个答案: