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
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....???
(18.12.2015, 12:05)Fredl55 schrieb: 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:
Zitat:Private Sub Worksheet_Change(ByVal Target As Range)
Call Ab6Arot
End Sub
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
18.12.2015, 14:26 (Dieser Beitrag wurde zuletzt bearbeitet: 18.12.2015, 14:26 von 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).
Beste Grüße Günther
Excel-ist-sexy.de …schau doch mal rein! Der Sicherheit meiner Daten wegen lade ich keine *.xlsm bzw. *.xlsb- Files mehr herunter! -> So geht's ohne!