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
Hallo,
änder diese Zeile:
so um:
@Atilla:
Danke, ich hatte vergessen, die letzte Testversion auf den Urzustand zurück zu setzen.
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
Hi Fred,
(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
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
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).
Sorry das ich mich erst jetzt melde, jetzt funk. alles, vielen Dank !!
Gruß Fred