Gleiche Werte finden

[Fredl55]

Hallo und guten morgen,
also das mit dem Code funktioniert nicht, jetzt ist der rote Eintrag weg und es sollte ja so sein, das im Bereich A1:K3 5x ein A zugelassen wird ab dem 6. Eintrag sollte das Feld rot unterlegt werden.
Ebenso in den Bereichen A4:K6 und A7:K9

Gruß Fred

[atilla]

Hallo,

änder diese Zeile:

Code:

Ze1 = 4

so um:

Code:

Ze1 = 1

[GMG-CC]

@Atilla:
Danke, ich hatte vergessen, die letzte Testversion auf den Urzustand zurück zu setzen.

[Fredl55]

Hallo Günther,
also bei mir geht leider gar nichts kannst du mir mal meine Mappe mit deinem code schicken..ich kann soviele "A" setzen wie ich will..da passiert nichts....???

Gruß Fred

[Rabe]

Hi Fred,

also bei mir geht leider gar nichts kannst du mir mal meine Mappe mit deinem code schicken..ich kann soviele "A" setzen wie ich will..da passiert nichts....???

setze noch dieses Makro hinter die Tabelle:

Private Sub Worksheet_Change(ByVal Target As Range)
Call Ab6Arot
End Sub

[atilla]

Hallo zusammen,

ich habe mal eine andre Variante versucht. Diese arbeitet etwas anders:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim bereich1 As Range, bereich2 As Range, bereich3 As Range
   Set bereich1 = Range("A1:K3")
   Set bereich2 = Range("A4:K6")
   Set bereich3 = Range("A7:K9")
   If Not Intersect(Target, bereich1) Is Nothing Then
       If UCase(Target.Text) = "A" Then
           If Application.CountIf(bereich1, Target.Text) > 5 Then
               Target.Interior.Color = vbRed
           Else
               bereich1.Interior.ThemeColor = xlThemeColorDark2
           End If
       Else
           If Application.CountIf(bereich1, "A") > 5 Then
               Target.Interior.ThemeColor = xlThemeColorDark2
           Else
               bereich1.Interior.ThemeColor = xlThemeColorDark2
           End If
       End If
   End If
   If Not Intersect(Target, bereich2) Is Nothing Then
       If UCase(Target.Text) = "A" Then
           If Application.CountIf(bereich2, Target.Text) > 5 Then
               Target.Interior.Color = vbRed
           Else
               bereich2.Interior.ThemeColor = xlThemeColorDark2
           End If
       Else
           If Application.CountIf(bereich2, "A") > 5 Then
               Target.Interior.ThemeColor = xlThemeColorDark2
           Else
               bereich2.Interior.ThemeColor = xlThemeColorDark2
           End If
       End If
   End If
   If Not Intersect(Target, bereich3) Is Nothing Then
       If UCase(Target.Text) = "A" Then
           If Application.CountIf(bereich3, Target.Text) > 5 Then
               Target.Interior.Color = vbRed
           Else
               bereich3.Interior.ThemeColor = xlThemeColorDark2
           End If
       Else
           If Application.CountIf(bereich3, "A") > 5 Then
               Target.Interior.ThemeColor = xlThemeColorDark2
           Else
               bereich3.Interior.ThemeColor = xlThemeColorDark2
           End If
       End If
   End If
End Sub

[GMG-CC]

So, ich habe dir jetzt einmal die Originaldatei als *.xls und als *.xlsm (beide in 1 File gepackt) beigefügt.
Natürlich kannst du mit festen Bereichen arbeiten, aber das macht das Ganze unflexibler. Wenn beispielsweise ein weiterer Datenblock dazu kommt. Und einen Button zum Auslösen des Makros habe ich auch noch dazu gefügt. - Und bislang war nicht unbedingt davon die Rede, dass bei jeder Änderung eine Neuberechnung erfolgen soll (zumindest habe ich das so nicht verstanden).

[Fredl55]

Sorry das ich mich erst jetzt melde, jetzt funk. alles, vielen Dank !!

Gruß Fred