Highlight if match in other Column Excel VBA-CodePudding

I tought I had this one figured out, but I was wrong. I want column D to highlight if it doesn't have a match in column C, but I need them to be in the same category in column A.

Column A is a dropdown with the folowing to chose from:

(EL), (Kallvatten, Varmvatten, Värme, IMD), (Fjärrvärme, Fjärrkyla, Hetgas), (IMD Exempel)

I put brackets around the groups. So column D need to have a match in column C and they need to be in the same group(column A).

This is my code right now, it works fine exept from the groups.

Dim rng1 As Range, rng2 As Range, x As Long, j As Long, bFault1 As Boolean
bFault1 = False
For x = 8 To Sheets("Mätplan").Range("D" & Rows.Count).End(xlUp).Row
    Set rng1 = Sheets("Mätplan").Range("D" & x)
    For j = 8 To Sheets("Mätplan").Range("C" & Rows.Count).End(xlUp).Row
        Set rng2 = Sheets("Mätplan").Range("C" & j)
        If (StrComp(Trim(rng1.Text), Trim(rng2.Text), vbTextCompare) = 0) Or IsEmpty(rng1) Then
            rng1.Interior.ColorIndex = xlNone
            Set rng2 = Nothing
            Exit For
        ElseIf (j = Sheets("Mätplan").Range("C" & Rows.Count).End(xlUp).Row) Then
            rng1.Interior.Color = RGB(255, 204, 204)
            bFault1 = True
        End If
        Set rng2 = Nothing
    Next j
    Set rng1 = Nothing
Next x

Screenshot

Thanks in advance!

CodePudding user response：

Add a check on group inside the second loop.

Sub macro1()

    Dim rng1 As Range, rng2 As Range, x As Long, j As Long
    Dim bMatch As Boolean, ws As Worksheet
    Dim Grp As String
    
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    With dict
        .Add "EL", 1
        .Add "Kallvatten", 2
        .Add "Varmvatten", 2
        .Add "Värme", 2
        .Add "IMD", 2
        .Add "Fjärrvärme", 3
        .Add "Fjärrkyla", 3
        .Add "Hetgas", 3
        .Add "IMD", 4
        .Add "Exempel", 4
    End With
    
    Set ws = Sheets("Mätplan")
    
    For x = 8 To ws.Range("D" & Rows.Count).End(xlUp).Row
        bMatch = False
        Grp = dict(Trim(ws.Range("A" & x)))
        Set rng1 = ws.Range("D" & x)
        For j = 8 To ws.Range("C" & Rows.Count).End(xlUp).Row
        
            ' match groups
            If Grp = dict(Trim(ws.Range("A" & j))) Then
                
                Set rng2 = ws.Range("C" & j)
                If (StrComp(Trim(rng1.Text), Trim(rng2.Text), vbTextCompare) = 0) Or IsEmpty(rng1) Then
                    bMatch = True
                    Exit For
                End If
                
            End If
        Next j
        
        If bMatch Then
            rng1.Interior.ColorIndex = xlNone
        Else
            rng1.Interior.Color = RGB(255, 204, 204)
        End If
        
    Next x
End Sub