如果单元格包含多个文本字符串的部分匹配，则应用条件格式VBA

Question

当前能够对 H:H 等列范围进行 VBA 搜索，并在 H:H 中的任何单元格与单元格 A1（可能是“LTD”）部分匹配时应用条件格式。然而，我正在努力寻找一个代码，允许我将部分匹配扩展到单元格 B1“CO”和 C1“LLC”与 H:H。理想情况下，我想使用一个代码根据 H:H 查看多个单元格，而不是必须多次运行代码才能获得条件格式。

VBA代码如下：

Private Sub CommandButton1_Click()
 
Dim Partial_Text As String
Dim myrange As Range

Partial_Text = Worksheets("Workbook").Cells(1, 1).Value
Set myrange = Worksheets("Workbook").Range("H:H")
myrange.Interior.Pattern = xlNone

For Each cell In myrange

    If InStr(LCase(cell.Value), LCase(Partial_Text)) <> 0 Then cell.Interior.ColorIndex = 4
 
Next

End Sub

有人可以帮助我并改进这个吗？

谢谢！

尝试了上面的代码，想要一个允许我运行 VBA 代码一次而不是多次的解决方案。我运行 VBA 代码的原因是因为在标准 Excel 公式中通配符不会获取部分匹配项，但 VBA 会。

Answer 1

也许是这样的：

Private Sub CommandButton1_Click()
 
    Dim cell As Range, ws As Worksheet
    Dim myrange As Range, v, arrTerms As Variant, r As Long
    
    Set ws = Worksheets("Workbook")
    Set myrange = ws.Range("H1:H" & ws.Cells(Rows.Count, "H").End(xlUp).row)
    myrange.Interior.Pattern = xlNone
    
    arrTerms = ws.Range("A1:C1").Value 'for example: all search terms
    
    For Each cell In myrange.Cells
        v = cell.Value
        If Len(v) > 0 Then
            For r = 1 To UBound(arrTerms, 1) 'loop array of search terms
                If InStr(1, v, arrTerms(r, 1), vbTextCompare) <> 0 Then
                    cell.Interior.ColorIndex = 4
                    Exit For 'no need to check further
                End If
            Next r
        End If  'anything to check
    Next        'cell to check

End Sub

Answer 2

尝试修改代码如下：

Private Sub CommandButton1_Click()
    Dim Partial_Text As Variant
    Dim myrange As Range
    Dim keywords As Variant
    Dim keyword As Variant

    ' Define the partial match keywords in an array
    keywords = Array("LTD", "CO", "LLC")

    Set myrange = Worksheets("Workbook").Range("H:H")
    myrange.Interior.Pattern = xlNone

    For Each cell In myrange
        For Each keyword In keywords
            Partial_Text = Worksheets("Workbook").Cells(1, keyword).Value
            If InStr(LCase(cell.Value), LCase(Partial_Text)) <> 0 Then
                cell.Interior.ColorIndex = 4
                Exit For ' Exit the loop if a match is found for this keyword
            End If
        Next keyword
    Next cell
End Sub

我希望它有效！ :)