优化条件格式VBA宏：仅生成列中已用关键词的颜色对照键

I get it—your current macro does the conditional formatting job just fine, but it dumps every preset keyword into the color key sheet, even if none of your target column cells actually contain them. Let's refactor this to only include keywords that are actively used, while keeping the formatting functionality intact.

Here's the revised macro with clear explanations of how it works:

Sub ColorCoringPluskey()
    Dim wsTarget As Worksheet
    Dim wsKey As Worksheet
    Dim keywordColorMap As Variant
    Dim cell As Range
    Dim usedKeywords As Collection
    Dim keyItem As Variant
    Dim lastRow As Long
    Dim i As Long, j As Long
    Dim keyword As String
    Dim found As Boolean
    
    ' Set reference to your target worksheet (adjust "Fees" if your sheet has a different name)
    Set wsTarget = ThisWorkbook.Worksheets("Fees")
    
    ' Create or reuse the color key sheet
    On Error Resume Next
    Set wsKey = ThisWorkbook.Worksheets("Color Coding Key")
    On Error GoTo 0
    If wsKey Is Nothing Then
        Set wsKey = ThisWorkbook.Worksheets.Add(After:=wsTarget)
        wsKey.Name = "Color Coding Key"
    Else
        ' Clear old content if the sheet already exists
        wsKey.Cells.Clear
    End If
    
    ' Centralized list of keywords and their matching colors (easy to update!)
    keywordColorMap = Array( _
        Array("Strategize", 10053120), _
        Array("Coordinate", 13421619), _
        Array("Committee", 16777062), _
        Array("Attention", 2162853), _
        Array("Work", 10092543), _
        Array("Circulate", 16764057), ' Fixed misspelling from original "Criculate"
        Array("Numerous", 65535), _
        Array("Follow up", 5296274), _
        Array("Attend" & vbCrLf & "Attend to", 16751001), _
        Array("Attention to", 32768), _
        Array("Print", 12611584), _
        Array("WIP", 10066431), _
        Array("Prepare" & vbCrLf & "Prepare for", 6737151), _
        Array("Develop", 49407), _
        Array("Participate", 15773696), _
        Array("Organize", 16744448), _
        Array("Various", 8421504), _
        Array("Maintain", 13092807), _
        Array("Team" & vbCrLf & "Team call", 3355443), _
        Array("Address", 16776960) _
    )
    
    ' Track keywords that actually appear in the target column
    Set usedKeywords = New Collection
    
    ' Find the last row with data in column G
    lastRow = wsTarget.Cells(wsTarget.Rows.Count, "G").End(xlUp).Row
    
    ' Scan column G to collect used keywords (skip header row if needed)
    For Each cell In wsTarget.Range("G2:G" & lastRow)
        If cell.Value <> "" Then
            For i = LBound(keywordColorMap) To UBound(keywordColorMap)
                keyword = keywordColorMap(i)(0)
                ' Check if cell contains the keyword (case-insensitive)
                If InStr(1, cell.Value, keyword, vbTextCompare) > 0 Then
                    ' Avoid duplicate entries in usedKeywords
                    found = False
                    For Each keyItem In usedKeywords
                        If keyItem = keyword Then
                            found = True
                            Exit For
                        End If
                    Next keyItem
                    If Not found Then
                        usedKeywords.Add keyword
                    End If
                End If
            Next i
        End If
    Next cell
    
    ' Clear old conditional formatting before applying new rules
    wsTarget.Columns("G:G").FormatConditions.Delete
    
    ' Apply conditional formatting rules from our keyword-color map
    For i = LBound(keywordColorMap) To UBound(keywordColorMap)
        keyword = keywordColorMap(i)(0)
        With wsTarget.Columns("G:G").FormatConditions.Add(Type:=xlTextString, String:=keyword, TextOperator:=xlContains)
            .Interior.Color = keywordColorMap(i)(1)
            .StopIfTrue = False
        End With
    Next i
    
    ' Set up color key sheet headers
    With wsKey
        .Range("A1").Value = "Word"
        .Range("B1").Value = "Color"
        ' Format headers for readability
        With .Range("A1:B1")
            .HorizontalAlignment = xlCenter
            .Font.Bold = True
            .Font.Underline = xlUnderlineStyleSingle
        End With
        .Columns("A:A").ColumnWidth = 13.43
        .Columns("B:B").ColumnWidth = 31.43
    End With
    
    ' Populate color key with only used keywords
    If usedKeywords.Count > 0 Then
        For i = 1 To usedKeywords.Count
            keyword = usedKeywords(i)
            wsKey.Cells(i + 1, "A").Value = keyword
            ' Match keyword to its color and apply to column B
            For j = LBound(keywordColorMap) To UBound(keywordColorMap)
                If keywordColorMap(j)(0) = keyword Then
                    wsKey.Cells(i + 1, "B").Interior.Color = keywordColorMap(j)(1)
                    Exit For
                End If
            Next j
        Next i
    Else
        wsKey.Cells(2, "A").Value = "No keywords found in target column"
    End If
    
    ' Clean up object references
    Set wsTarget = Nothing
    Set wsKey = Nothing
    Set usedKeywords = Nothing
End Sub

Key Fixes & Improvements: #

• No more Select/ActiveCell: This makes the macro faster and avoids bugs caused by accidental sheet switches.
• Centralized keyword management: All keywords and colors live in one array—easy to add/remove entries later.
• Used keyword tracking: We scan the target column first to collect only keywords that actually appear, so the color key stays clean.
• Reusable color key sheet: If the "Color Coding Key" sheet already exists, it clears old content instead of creating duplicates.
• Case-insensitive matching: Catches both "ATTENTION" and "attention" without extra work.

Quick Setup: #

1. Replace "Fees" with your actual target worksheet name if needed.
2. Double-check the keywordColorMap array to make sure all your keywords and colors are included (I fixed the "Criculate" typo for you!).
3. Run the macro—it will handle both conditional formatting and the trimmed-down color key automatically.

内容的提问来源于stack exchange，提问作者Hayden Shirts