Excel VBA: Match Cell Color

问题

I have a workbook with two sheets. On Sheet A, I have changed the interior color of some cells. I would like to find cells in Sheet B with matching text and set them to have the same interior color. However, when I get to hRow = Application..., I receive an error that The application does not support this object or property. I've been searching for similar functions, but I am not having any success finding a good way to match text without looping through each cell in a range.

Public Sub MatchHighlight()

Dim lRow As Integer
Dim i As Integer
Dim hRow As Integer

Dim LookUpRange As Range
Set LookUpRange = Worksheets("HR - Highlight").Range("C2:C104")

Dim compare As Range
Set compare = Worksheets("Full List").Range("C2:C277")

lRow = Worksheets("Full List").UsedRange.Rows.Count

For i = 2 To lRow

    hRow = Application.Worksheets("Full List").WorksheetFunction.Match(compare.Range("C" & i).Text, LookUpRange, 0)

    If Not IsNull(hRow) Then

        compare.Range("C" & i).Interior.Color = LookUpRange.Range("C" & hRow).Interior.Color

    End If

Next i

End Sub

回答1:

Sub MatchHighlight()

    Dim wsHighlight As Worksheet
    Dim wsData As Worksheet
    Dim rngColor As Range
    Dim rngFound As Range
    Dim KeywordCell As Range
    Dim strFirst As String

    Set wsHighlight = Sheets("HR - Highlight")
    Set wsData = Sheets("Full List")

    With wsData.Columns("C")
        For Each KeywordCell In wsHighlight.Range("C2", wsHighlight.Cells(Rows.Count, "C").End(xlUp)).Cells
            Set rngFound = .Find(KeywordCell.Text, .Cells(.Cells.Count), xlValues, xlWhole)
            If Not rngFound Is Nothing Then
                strFirst = rngFound.Address
                Set rngColor = rngFound
                Do
                    Set rngColor = Union(rngColor, rngFound)
                    Set rngFound = .Find(KeywordCell.Text, rngFound, xlValues, xlWhole)
                Loop While rngFound.Address <> strFirst
                rngColor.Interior.Color = KeywordCell.Interior.Color
            End If
        Next KeywordCell
    End With

End Sub

回答2:

To get exactly what I wanted, I used @tigeravatar's code as a base and ended up with the following:

Sub MatchHighlight()

Dim wsHighlight As Worksheet
Dim wsData As Worksheet
Dim rngColor As Range
Dim rngFound As Range
Dim KeywordCell As Range
Dim strFirst As String
Dim rngPicked As Range

Set rngPicked = Application.InputBox("Select Cell", Type:=8)
Set wsHighlight = Sheets("HR - Highlight")
Set wsData = Sheets("Full List")

With wsData.Columns("C")
    For Each KeywordCell In wsHighlight.Range("C2", wsHighlight.Cells(Rows.Count, "C").End(xlUp)).Cells
        Set rngFound = .Find(KeywordCell.Text, .Cells(.Cells.Count), xlValues, xlWhole)
        If Not rngFound Is Nothing Then
            strFirst = rngFound.Address
            Set rngColor = rngFound
            Do
                Set rngColor = Union(rngColor, rngFound)
                Set rngFound = .Find(KeywordCell.Text, rngFound, xlValues, xlWhole)
            Loop While rngFound.Address <> strFirst

            Set rngColor = rngColor.Offset(0, -2).Resize(1, 3)

            If KeywordCell.Interior.Color = rngPicked.Interior.Color Then
                rngColor.Interior.Color = KeywordCell.Interior.Color
            End If
        End If
    Next KeywordCell
End With

End Sub

Only real differences are that I let the user pick the color of cells they're trying to match, I only change the interior color when it matches the color picked, and I change the color of the whole row.

来源：https://stackoverflow.com/questions/18876456/excel-vba-match-cell-color