CODEWITHSUNDEEP
excelvba
tmoore82
tmoore82

Reputation: 1875

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

Upvotes: 2

Views: 4430

Answers (3)

dreojs16
dreojs16

Reputation: 117

This can be done much much faster with:

Option Explicit

Sub MatchHighlight()


Dim FullListCell As Range
Dim HighlightMasterCell As Range
Dim FullList As Range
Dim HighlightMaster As Range
Dim lastRow As Range

'find last row in FullList
Set lastRow = Range("C").End(xlDown)

Set HighlightMaster = ThisWorkbook.Sheets("kleuren_medewerkers").Range("A1:A100")

Set FullList = Range(Range("C2"), ActiveSheet.Cells(lastRow.Row, 3)) 'change the number 3 to include more columns but use the lastrow of column C


For Each HighlightMasterCell In HighlightMaster 
    For Each FullListCell In FullList 
        If FullListCell .Value = HighlightMasterCell.Value Then
            FullListCell.Interior.Color= HighlightMasterCell.Interior.Color
        End If

     Next
Next

End Sub

Upvotes: 0

tmoore82
tmoore82

Reputation: 1875

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.

Upvotes: 1

tigeravatar
tigeravatar

Reputation: 26640

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

Upvotes: 3

Related Questions