Controle namen met bijzonderheid

[Gerard2348]

Beste forumleden,

Per dag heb ik een lijst met namen van personen. Van sommige personen is er een bijzonderheid aanwezig. De namen met een bijzonderheid staan in dit voorbeeld gedefinieerd op Blad 3. Deze namen kan ik een bepaalde kleur geven via een VBA Code. In deze code heb ik de namen met bijzonderheid apart benoemd. Is het mogelijk om deze code zo aan te passen dat de namen automatisch worden geselecteerd uit de lijst uit Blad 3. Dus m.a.w. wanneer er een naam wijzigt met een bijzonderheid dat ik kan volstaan met de wijziging in de namen met bijzonderheid in blad 3.

Bijlage in beknopte vorm;
Bekijk bijlage namencheck.xlsm

Met vriendelijke groet,

Geer

 

[Warme bakkertje]

Heb hier en daar wat bereiken aangepast voor de werking, maar de bedoeling zal wel duidelijk zijn.
Belangrijkste begint vanaf With Sheets("Blad3")

Sub personenmetbijzonderheid()
    For Each cell In Range("n2:n148")
        If cell.Value <> "" Then
            With cell
                With .Interior
                    .ColorIndex = xlNone
                End With
                .Offset(0, -1).Font.ColorIndex = 15
            End With
        End If
    Next
    With Sheets("Blad3")
        sn = Join(Application.Transpose(.Range("D2:D" & .Cells(Rows.Count, 4).End(xlUp).Row)), ";")
    End With
    For Each cell In Range("n2:n148")
        If InStr(1, sn, cell.Value, vbTextCompare) > 0 Then
            With cell.Interior
                .ColorIndex = 19
            End With
            With cell.Font
                .Bold = True
                .ColorIndex = 5
            End With
        End If
    Next
End Sub

 

[Gerard2348]

Ha Rudi,

Ben je zeer erkentelijk. Met een paar kleine aanpassingen heb ik wat ik wil. :thumb:

Sub personenmetbijzonderheid()
    [COLOR="#FF0000"]For Each cell In Range("B2:F50")[/COLOR]  
      If cell.Value <> "" Then
            With cell
                With .Interior
                    .ColorIndex = xlNone
                End With
                .Offset(0, -1).Font.ColorIndex = 15
            End With
        End If
    Next
    With Sheets("Blad3")
        sn = Join(Application.Transpose(.Range("D2:D" & .Cells(Rows.Count, 4).End(xlUp).Row)), ";")
    End With
    [COLOR="#FF0000"]For Each cell In Range("B2:F50")[/COLOR]
        If InStr(1, sn, cell.Value, vbTextCompare) [COLOR="#FF0000"]> 1[/COLOR] Then
            With cell.Interior
                .ColorIndex = 19
            End With
            With cell.Font
                .Bold = True
                .ColorIndex = 5
            End With
        End If
    Next
End Sub

Helemaal Top
Groetjes Geer,

 

[Gerard2348]

Rudi,

Jouw code werkt als een tierelier. Maar ik heb toch nog een vraag. Er wordt nu gekeken naar een exacte overeenkomst wat uiteraard in de eerste instantie de bedoeling is. In mijn eerste voorbeeld gebruikte ik de Like functie. Dus de naam plus eventueel een toevoeging werd meegenomen in de vergelijk. Is dit hier ook te realiseren.

MvG Geer

 

[HSV]

Probeer onderstaande versie eens.

Sub personenmetbijzonderheid()
    For Each cell In Blad2.Range("B2:F50")
      If cell.Value <> "" Then
            With cell
                With .Interior
                    .ColorIndex = xlNone
                End With
                .Offset(0, -1).Font.ColorIndex = 15
            End With
        End If
    Next
    With Sheets("Blad3")
        sn = Split(Join(Application.Transpose(.Range("D2:D" & .Cells(Rows.Count, 4).End(xlUp).Row)), ";"), ";")
    End With
    For i = LBound(sn) To UBound(sn)
     Set c = Blad2.Range("B2:F50").Find(sn(i), , , xlPart)
        If Not c Is Nothing Then
            With c.Interior
                .ColorIndex = 19
            End With
            With c.Font
                .Bold = True
                .ColorIndex = 5
            End With
        End If
    Next
End Sub

 

[Gerard2348]

Goede morgen Harry,

Mijn hartelijke dank voor jouw bijdrage. Heb het net getest en volgens mij loop het als een zonnetje. :thumb:

Groet Geer

 

[Gerard2348]

Goedemorgen,

De code werkt als een tierelier. Heb er veel plezier van. Maar er is toch nog een ding wat ik wilde vragen. Op het moment dat een naam 2 keer voorkomt wordt er 1 naam gekleurd en de andere niet. Is het mogelijk dat wanneer dit zich voordoet dat beide namen gekleurd worden.

 

[HSV]

Daar doen we het voor Gerard.

Sub personenmetbijzonderheid()
    For Each cell In Blad2.Range("B2:F50")
      If cell.Value <> "" Then
            With cell
                With .Interior
                    .ColorIndex = xlNone
                End With
                .Offset(0, -1).Font.ColorIndex = 15
            End With
        End If
    Next
    With Sheets("Blad3")
        sn = Split(Join(Application.Transpose(.Range("D2:D" & .Cells(Rows.Count, 4).End(xlUp).Row)), ";"), ";")
    End With
    For i = LBound(sn) To UBound(sn)
     Set c = Blad2.Range("B2:F50").Find(sn(i), , , xlPart)
        If Not c Is Nothing Then
        firstaddress = c.Address
        Do
            With c.Interior
                .ColorIndex = 19
            End With
            With c.Font
                .Bold = True
                .ColorIndex = 5
            End With
        Set c = Blad2.Range("B2:F50").FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstaddress
        End If
    Next
End Sub

 

[Gerard2348]

Harry,

Je bent de bovenste beste. Mijn hartelijke dank..:thumb:

 

[HSV]

Graag gedaan.