Макрос условного форматирования с ключом - PullRequest
Новая
       26

Макрос условного форматирования с ключом

0 голосов
/ 23 мая 2018

Я пытаюсь создать макрос для условного форматирования столбца.Чтобы изменить цвет заливки для ячеек на основе ключевых слов, содержащихся в ячейках, я также пытаюсь сделать так, чтобы этот макрос создавал новый лист и выводил ключ, содержащий только ключевые слова, и заливал цвета для ключевых слов, содержащихся встолбец, который форматируется.

Так, например, если у меня есть список ключевых слов, который имеет 30 слов, и в этом случае в столбце используются только 9 слов, то будет выведен ключ на отдельном листе, который содержит только 9 используемых слов вместес соответствующими цветами заливки.

Вот так выглядит макрос в настоящий момент: он будет условно форматировать столбец и создавать новый лист, который выводит ключ, но содержит все ключевые слова, даже если они не используются.

Sub ColorCoringPluskey()
'
' ColorCoringPluskey Macro
'

'
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "Color Coding Key"
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Word"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Color"
    Range("A1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("B1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A1:B1").Select
    Selection.Font.Bold = True
    Selection.Font.Underline = xlUnderlineStyleSingle
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "Strategize"
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "Coordinate"
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "Committee"
    Range("A5").Select
    ActiveCell.FormulaR1C1 = "Attention"
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "Work"
    Range("A7").Select
    ActiveCell.FormulaR1C1 = "Criculate"
    Range("A8").Select
    ActiveCell.FormulaR1C1 = "Numerous"
    Range("A9").Select
    ActiveCell.FormulaR1C1 = "Follow up"
    Range("A10").Select
    ActiveCell.FormulaR1C1 = "Attend" & Chr(10) & "Attend to"
    Range("A11").Select
    ActiveCell.FormulaR1C1 = "Attention to"
    Range("A12").Select
    ActiveCell.FormulaR1C1 = "Print"
    Range("A13").Select
    ActiveCell.FormulaR1C1 = "WIP"
    Range("A14").Select
    ActiveCell.FormulaR1C1 = "Prepare" & Chr(10) & "Prepare for"
    Range("A15").Select
    ActiveCell.FormulaR1C1 = "Develop"
    Range("A16").Select
    ActiveCell.FormulaR1C1 = "Participate"
    Range("A17").Select
    ActiveCell.FormulaR1C1 = "Organize"
    Range("A18").Select
    ActiveCell.FormulaR1C1 = "Various"
    Range("A19").Select
    ActiveCell.FormulaR1C1 = "Maintain"
    Range("A20").Select
    ActiveCell.FormulaR1C1 = "Team" & Chr(10) & "Team call"
    Range("A21").Select
    ActiveCell.FormulaR1C1 = "Address"
    Range("B2").Select
    Columns("A:A").ColumnWidth = 13.43
    Columns("B:B").ColumnWidth = 31.43
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 10053120
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B3").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 13421619
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B4").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 16777062
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Sheets("Fees").Select
    Columns("G:G").Select
    Selection.FormatConditions.Add Type:=xlTextString, String:="Strateg", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 10053120
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="Coordinate", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13421619
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="Committee", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 16777062
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="Attention", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 2162853
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="Work", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 5263615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="Circulate", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 10066431
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Sheets("Color Coding Key").Select
    Range("B5").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 2162853
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B6").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 5263615
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B7").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 10066431
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B8").Select
    Sheets("Fees").Select
    Selection.FormatConditions.Add Type:=xlTextString, String:="Numer", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13158
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="Follow Up", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="atten", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="Print", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 10092543
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Sheets("Color Coding Key").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 13158
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B9").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 39372
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B10").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B11").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 10092543
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B11").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B12").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 10092543
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Sheets("Fees").Select
    Selection.FormatConditions.Add Type:=xlTextString, String:="WIP", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13056
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="Prep", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 32768
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="develop", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 3394611
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Sheets("Color Coding Key").Select
    Range("B13").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 13056
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B14").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 32768
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B15").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 3394611
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B16").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 10092441
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Sheets("Fees").Select
    Selection.FormatConditions.Add Type:=xlTextString, String:="Particip", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 10092441
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="Organize", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13369548
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="Various", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 16751103
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Sheets("Color Coding Key").Select
    Range("B17").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 13369548
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B18").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 16751103
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B19").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 16724787
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B20").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 16750950
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("B21").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 6697881
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Sheets("Fees").Select
    Selection.FormatConditions.Add Type:=xlTextString, String:="Maintain", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 16724787
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="Team", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 16750950
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Selection.FormatConditions.Add Type:=xlTextString, String:="address", _
        TextOperator:=xlContains
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 6697881
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Sheets("Fees").Select
End Sub

1 Ответ

0 голосов
/ 24 мая 2018

Я думаю, это то, что вы ищете.Обратите внимание, что он не находит «Внимание», потому что сначала находит «Внимание».Чтобы добиться успеха, упорядочите их в порядке приоритета для находок (сначала список будет найден первым) или убедитесь, что у вас не будет повторяющихся частичных совпадений, подобных этому. 

Sub ColorCoringPluskey()
'
' ColorCoringPluskey Macro
'

    Dim wb As Workbook
    Dim wsKey As Worksheet
    Dim wsFees As Worksheet
    Dim aKeyColors(1 To 20, 1 To 2) As Variant
    Dim aOutput() As Variant
    Dim sKeyShName As String
    Dim i As Long, j As Long

    Set wb = ActiveWorkbook
    Set wsFees = wb.Sheets("Fees")
    sKeyShName = "Color Coding Key"

    On Error Resume Next
    Set wsKey = wb.Sheets(sKeyShName)
    On Error GoTo 0
    If wsKey Is Nothing Then
        Set wsKey = wb.Sheets.Add(After:=ActiveSheet)
        wsKey.Name = sKeyShName
        With wsKey.Range("A1:B1")
            .Value = Array("Word", "Color")
            .HorizontalAlignment = xlCenter
            .Font.Bold = True
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
        End With
    Else
        wsKey.Range("A2:B" & wsKey.Rows.Count).Clear
    End If

    aKeyColors(1, 1) = "Strategize":    aKeyColors(1, 2) = 10053120
    aKeyColors(2, 1) = "Coordinate":    aKeyColors(2, 2) = 13421619
    aKeyColors(3, 1) = "Committee":     aKeyColors(3, 2) = 16777062
    aKeyColors(4, 1) = "Attention":     aKeyColors(4, 2) = 2162853
    aKeyColors(5, 1) = "Work":          aKeyColors(5, 2) = 5263615
    aKeyColors(6, 1) = "Circulate":     aKeyColors(6, 2) = 10066431
    aKeyColors(7, 1) = "Numerous":      aKeyColors(7, 2) = 13158
    aKeyColors(8, 1) = "Follow up":     aKeyColors(8, 2) = 39372
    aKeyColors(9, 1) = "Attend":        aKeyColors(9, 2) = 65535
    aKeyColors(10, 1) = "Attention to": aKeyColors(10, 2) = 65535
    aKeyColors(11, 1) = "Print":        aKeyColors(11, 2) = 10092543
    aKeyColors(12, 1) = "WIP":          aKeyColors(12, 2) = 13056
    aKeyColors(13, 1) = "Prepare":      aKeyColors(13, 2) = 32768
    aKeyColors(14, 1) = "Develop":      aKeyColors(14, 2) = 3394611
    aKeyColors(15, 1) = "Participate":  aKeyColors(15, 2) = 10092441
    aKeyColors(16, 1) = "Organize":     aKeyColors(16, 2) = 13369548
    aKeyColors(17, 1) = "Various":      aKeyColors(17, 2) = 16751103
    aKeyColors(18, 1) = "Maintain":     aKeyColors(18, 2) = 16724787
    aKeyColors(19, 1) = "Team":         aKeyColors(19, 2) = 16750950
    aKeyColors(20, 1) = "Address":      aKeyColors(20, 2) = 6697881

    wsFees.Cells.FormatConditions.Delete
    ReDim aOutput(1 To UBound(aKeyColors, 1), 1 To 2)
    With wsFees.Columns("G")
        For i = LBound(aKeyColors, 1) To UBound(aKeyColors, 1)
            If WorksheetFunction.CountIf(.Cells, "*" & aKeyColors(i, 1) & "*") > 0 Then
                j = j + 1
                aOutput(j, 1) = aKeyColors(i, 1)
                aOutput(j, 2) = aKeyColors(i, 2)
                .FormatConditions.Add xlTextString, String:=aKeyColors(i, 1), TextOperator:=xlContains
                .FormatConditions(.FormatConditions.Count).Interior.Color = aKeyColors(i, 2)
            End If
        Next i
    End With

    If j > 0 Then
        wsKey.Range("A2").Resize(j, 1).Value = aOutput
        For i = 1 To j
            wsKey.Cells(i + 1, "B").Interior.Color = aOutput(i, 2)
        Next i
        wsKey.Columns("A").EntireColumn.AutoFit
    End If

End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Похожие темы

...