查找范围内的值并设置与其相邻的范围的格式

Question

每隔第二或第三行但不同的列中都有一个“ TO：”值。 我一直试图在工作表中找到“ TO：”，然后用红色填充单元格，直到A列向后。 我找到了一个宏并将其自定义如下。 我设法用红色为“ TO：”上色，但直到列A都没有设法将颜色填充到单元格中。例如，如果在L2中找到TO，则用红色L2：A2填充，同样如此。 任何帮助将不胜感激。

Sub FindAndChangeStyle()

Dim TestPhrases() As String
Dim rng, Rng2 As Range
Dim lastCol, i As Long
TestPhrases = Split("TO:", "KotaPota")
 Set rng = ActiveSheet.Range(ActiveSheet.UsedRange.Address)


With ActiveSheet
Dim oLookin As Range
   Dim CheckCell As Range
    For Each CheckCell In rng


        Dim Looper As Long
        For Looper = LBound(TestPhrases) To UBound(TestPhrases)

            If InStr(CheckCell.Value, TestPhrases(Looper)) Then
                CheckCell.Font.Bold = True
                CheckCell.Interior.Color = vbRed

                Exit For
            End If


        Next Looper

    Next CheckCell
End With

   End Sub

Answer 1

除非我缺少任何内容，否则也许您可以循环浏览所有包含"TO:"子字符串的单元格（使用Range.Find ）。

下面的代码将尝试查找"TO:"子字符串的所有不区分大小写的部分匹配项，并对该行的单元格应用某种格式（从A列开始，到包含该子字符串的单元格结束）。

Option Explicit

Private Sub ColourMatchingCells()
    With ThisWorkbook.Worksheets("Sheet1")

        Dim matchFound As Range
        Set matchFound = .Cells.Find("TO:", , xlValues, xlPart, xlByRows, xlNext, False) ' This will search all cells (of the sheet). Change as needed. '

        If matchFound Is Nothing Then
            MsgBox ("Could not find a single cell containing the substring. Code will stop running now.")
            Exit Sub
        End If

        Dim addressOfFirstMatch As String
        addressOfFirstMatch = matchFound.Address

        Do
            With .Range(.Cells(matchFound.Row, "A"), matchFound)
                .Font.Bold = True
                .Interior.Color = vbRed
            End With
            Set matchFound = .Cells.FindNext(matchFound)
        Loop Until matchFound.Address = addressOfFirstMatch ' Once you have looped through all matches, you should return to the first one '
    End With
End Sub