CODEWITHSUNDEEP
excelvba
apo02
apo02

Reputation: 15

Highlight if match in other Column

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 following to choose from:

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

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

There are no groups right now, it is just a dropdown with the following choises: EL, Kallvatten, Varmvatten, Värme, IMD, Fjärrvärme, Fjärrkyla, Hetgas, IMD Exempel. But I would like the groups to be like this (EL) (Kallvatten, Varmvatten, Värme, IMD) (Fjärrvärme, Fjärrkyla, Hetgas) (IMD Exempel).

My code works except 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

Upvotes: 0

Views: 124

Answers (1)

CDP1802
CDP1802

Reputation: 16357

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

Upvotes: 1

Related Questions