Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
856to860
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
856to860
856to860
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Bedingte Formatierung über VBA ....

Bedingte Formatierung über VBA ....
29.03.2007 20:39:25
proxima05

Hallo, guten Abend
ich bin auf der Suche nach einem Code, der mir für einen Datenbestand den größten/kleinsten, zweitgrößten/zweitkleinsten Wert farbig markiert. Die Formeln, die ich pro Zelle verwenden will, sind die folgenden
Größter/Kleinster Wert
Formula Is =(F5=MAX($F$5:$F$20))*(COUNT($F$5:$F$20)>0)
Formula Is =(F5=MIN($F$5:$F$20))*(COUNT($F$5:$F$20)>0)
Interior.ColorIndex = 43
Interior.ColorIndex = 3
Zweitgrößter/Zweitkleinster Wert
Formula Is =F5=LARGE($F$5:$F$20;2)
Formula Is =F5=SMALL($F$5:$F$20;2)
Interior.ColorIndex = 40
Interior.ColorIndex = 5
Realisieren möchte ich das mit dem folgenden teils begonnenen Code. Mir geht es jetzt um die Einbindung der oben geschriebenen Formel in die drei aufgeführten Datenbereiche (in denen stehen alle prozentuale Veränderungen)
*******************************************************


Private Sub FX_Rate_Live_Change(ByVal Target As Excel.Range)
'Bedingte Formatierung der Zellen mit der höchsten/zweithöchsten/kleinsten/zweitkleinsten
'prozentualen Veränderung. Die Anpassung der Formatierung erfolgt dynamisch mit jedem Wechsel
'der Inhalte des Worksheet.
Dim DatenBereich1 As Range
Dim DatenBereich2 As Range
Dim DatenBereich3 As Range
Dim DatenZelle As Range
'Bereiche mit den prozentualen Veränderungen
Set DatenBereich1 = Range("F5:F20")
Set DatenBereich2 = Range("F22:F36")
Set DatenBereich3 = Range("N5:N20")
For Each DatenZelle In Range(Target.Address)
If Not Intersect(DatenZelle, DatenBereich1) Is Nothing Then
End Sub

*******************************************************
Wäre riesig, wenn mir da jemand helfen können. Ich habe zwar schon mehrere Möglichkeiten in anderen Tabellen gesehen (Select Case), aber keine hat so richtig einen Anstoss für die Formeleinbindung gegeben.
Besten Dank im voraus & Gruß
Ralph

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bedingte Formatierung über VBA ....
30.03.2007 00:17:16
Mustafa
Hallo Ralph,
Folgender Code gehört in das Modul der Tabelle :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Datenbereich1 As Range
Dim Datenbereich2 As Range
Dim Datenbereich3 As Range
Dim Rng As Range
Set Datenbereich1 = Range("F5:F20")
Set Datenbereich2 = Range("F22:F36")
Set Datenbereich3 = Range("N5:N20")
Datenbereich1.Interior.ColorIndex = xlNone
Datenbereich2.Interior.ColorIndex = xlNone
Datenbereich3.Interior.ColorIndex = xlNone
If Not Intersect(Target, Datenbereich1) Is Nothing Or Not Intersect(Target, Datenbereich2) Is  _
Nothing Or Not Intersect(Target, Datenbereich3) Is Nothing Then
' Kleinste und Größte Werte Markieren
For Each Rng In Datenbereich1
If Rng = WorksheetFunction.Max(Datenbereich1) And WorksheetFunction.Count(Datenbereich1) _
> 0 Then Rng.Interior.ColorIndex = 43
If Rng = WorksheetFunction.Min(Datenbereich1) And WorksheetFunction.Count(Datenbereich1) _
> 0 Then Rng.Interior.ColorIndex = 3
Next
For Each Rng In Datenbereich2
If Rng = WorksheetFunction.Max(Datenbereich2) And WorksheetFunction.Count(Datenbereich2) _
> 0 Then Rng.Interior.ColorIndex = 43
If Rng = WorksheetFunction.Min(Datenbereich2) And WorksheetFunction.Count(Datenbereich2) _
> 0 Then Rng.Interior.ColorIndex = 3
Next
For Each Rng In Datenbereich3
If Rng = WorksheetFunction.Max(Datenbereich3) And WorksheetFunction.Count(Datenbereich3) _
> 0 Then Rng.Interior.ColorIndex = 43
If Rng = WorksheetFunction.Min(Datenbereich3) And WorksheetFunction.Count(Datenbereich3) _
> 0 Then Rng.Interior.ColorIndex = 3
Next
' 2. kleinste und 2. größte Werte Markieren
For Each Rng In Datenbereich1
If Rng = WorksheetFunction.Large(Datenbereich1, 2) Then Rng.Interior.ColorIndex = 40
If Rng = WorksheetFunction.Small(Datenbereich1, 2) Then Rng.Interior.ColorIndex = 5
Next
For Each Rng In Datenbereich2
If Rng = WorksheetFunction.Large(Datenbereich2, 2) Then Rng.Interior.ColorIndex = 40
If Rng = WorksheetFunction.Small(Datenbereich2, 2) Then Rng.Interior.ColorIndex = 5
Next
For Each Rng In Datenbereich3
If Rng = WorksheetFunction.Large(Datenbereich3, 2) Then Rng.Interior.ColorIndex = 40
If Rng = WorksheetFunction.Small(Datenbereich3, 2) Then Rng.Interior.ColorIndex = 5
Next
End If
End Sub
Rückmeldung obs Hilft wäre nett.
Viele Grüße aus Köln.
Anzeige
AW: Bedingte Formatierung über VBA ....
30.03.2007 12:36:49
proxima05
Hallo Mustafa,
vielen Danke erstmal für die Hilfe. Ich habe den Code mal verwendet und er funktioniert auch. Trotzdem habe ich ab und an Probleme (vielleicht habe ich ihn auch an eine falsche Stelle gesetzt) derart, dass ich den sich aktualisierenden Datenbereich erst anklicken muss, damit sich die Hintergrundfarben entsprechend aktualisieren. Hinzukommt, dass trotz der Formel und definierter Farben, diese im Datenbereich2 umkehren bzw. im Datenbereich3 nur teilweise aktualisieren. Da es mit Worten recht schwer zu beschreiben, habe ich die Datei mal hochgeladen (dort kann das Problem reproduziert werden).

Die Datei https://www.herber.de/bbs/user/39.xls wurde aus Datenschutzgründen gelöscht


Noch eine Frage: Gibt es die Möglichkeit, dass der Datenbereich abwechselnde Farben (und nicht nur XLnone) enthält, so wie in der Spalte A bzw. L.
Besten für Deine Unterstützung.
Gruß
Ralph
Anzeige
Noch etwas festgestellt ....
30.03.2007 14:04:22
proxima05
... ich habe auch noch festgestellt, dass irgendwie die Reihefolge (höchster, zweithöchster, kleinster, zweitkleinster Wert) auch nicht eingehalten wird.
Ich hoffe Du kannst mir helfen.
Gruß
Ralph
AW: Noch etwas festgestellt ....
31.03.2007 06:27:57
Mustafa
Hallo Ralph,
Zum Problem mit dem Hineinklicken in die Zelle ist schnell geholfen.
Ändere die Anfangszeile vom Code von :
Private Sub Worksheet_Change(ByVal Target As Range)
Nach :
Private Sub Worksheet_Calculate()
Zu dem zweiten Problem muss ich mich etwas reinarbeiten, weil wie ich sehe negative zahlen drin vorkommen.
Aber da ich erst am Sonntag Abend wieder Online werde kann es etwas dauern.
Vielleicht wirst du in der zwischenzeit ja in der Recherche noch fündig wenn du nach kleinstem Wert mit negativen Zahlen suchst.
Wünsche ein Schönes WE.
Viele Grüße aus Köln.
Anzeige
AW: Noch etwas festgestellt ....
31.03.2007 16:42:36
proxima05
Danke für den Tipp mit Calculate()....
... bis später!
Gruß
Ralph
AW: Noch etwas festgestellt ....
31.03.2007 20:34:10
proxima05
Hallo Mustafa,
ich habe gerade die Sub-Definition nach Calculate() geändert .... wenn sich die Daten danach aktualisieren, dann erhalte ich die Fehlermeldung
'Run-time Error '424:
Object Required
Im Code selbst wird danach der folgende Abschnitt markiert (da "Target = Empty):
If Not Intersect(Target, Datenbereich1) Is Nothing Or Not Intersect(Target, Datenbereich2) Is _
Nothing Or Not Intersect(Target, Datenbereich3) Is Nothing Then
Wie kann ich das denn ändern ... den Befehl Intersect brauche ich doch, um mehrere Zellen auswerten zu können, oder?
Ich habe den Code mal wie folgt modifiziert. Bin mir aber nicht sicher, ob das so stimmt:

Private Sub Worksheet_Calculate()
Worksheet_Change Range("F5:F20")
Worksheet_Change Range("F22:F36")
Worksheet_Change Range("N5:N19")
End Sub

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim Datenbereich1 As Range
Dim Datenbereich2 As Range
Dim Datenbereich3 As Range
Dim Rng As Range
Set Datenbereich1 = Range("F5:F20")
Set Datenbereich2 = Range("F22:F36")
Set Datenbereich3 = Range("N5:N19")
Datenbereich1.Interior.ColorIndex = xlNone
Datenbereich2.Interior.ColorIndex = xlNone
Datenbereich3.Interior.ColorIndex = xlNone
If Not Intersect(Target, Datenbereich1) Is Nothing Or Not Intersect(Target, Datenbereich2) Is _
Nothing Or Not Intersect(Target, Datenbereich3) Is Nothing Then
Wäre toll, wenn Du dir das nochmal anschauen könntest.
Danke & Gruß
Ralph

Anzeige
Ich glaube, der ergänzte Code ist die Lösung ...
31.03.2007 22:10:02
proxima05
... ich meine mit der leichten Modifikation (ByVal Target As Excel.Range) und der separaten Sub für Calculate() wird die farblich Markierung korrekt vorgenommen, inkl. der negativen Werte.
Wäre aber trotzdem klasse, wenn Du nochmal drüberschaust.
Danke vorab.
Gruß
Ralph
AW: Ich glaube, der ergänzte Code ist die Lösung ...
01.04.2007 23:01:05
Mustafa
Hallo Rakph,
Sorry das war mein Fehler, die Zeile If Not Intersect ... brauchst du nicht mehr.
Zudem muss der Befehl End If am ende des Codes auch raus.
Hatte in der Eile des WE das noch vergessen.
Der Code würde dann wie Folgt aussehen:

Private Sub Worksheet_Calculate()
Dim Datenbereich1 As Range
Dim Datenbereich2 As Range
Dim Datenbereich3 As Range
Dim Rng As Range
Set Datenbereich1 = Range("F5:F20")
Set Datenbereich2 = Range("F22:F36")
Set Datenbereich3 = Range("N5:N20")
Datenbereich1.Interior.ColorIndex = xlNone
Datenbereich2.Interior.ColorIndex = xlNone
Datenbereich3.Interior.ColorIndex = xlNone
' Kleinste und Größte Werte Markieren
For Each Rng In Datenbereich1
If Rng = WorksheetFunction.Max(Datenbereich1) And WorksheetFunction.Count(Datenbereich1) _
_
> 0 Then Rng.Interior.ColorIndex = 4   'Farbe für den größten Plus-Wert
If Rng = WorksheetFunction.Min(Datenbereich1) And WorksheetFunction.Count(Datenbereich1) _
_
> 0 Then Rng.Interior.ColorIndex = 3   'Farbe für den größten Minus-Wert
Next
For Each Rng In Datenbereich2
If Rng = WorksheetFunction.Max(Datenbereich2) And WorksheetFunction.Count(Datenbereich2) _
_
> 0 Then Rng.Interior.ColorIndex = 4
If Rng = WorksheetFunction.Min(Datenbereich2) And WorksheetFunction.Count(Datenbereich2) _
_
> 0 Then Rng.Interior.ColorIndex = 3
Next
For Each Rng In Datenbereich3
If Rng = WorksheetFunction.Max(Datenbereich3) And WorksheetFunction.Count(Datenbereich3) _
_
> 0 Then Rng.Interior.ColorIndex = 4
If Rng = WorksheetFunction.Min(Datenbereich3) And WorksheetFunction.Count(Datenbereich3) _
_
> 0 Then Rng.Interior.ColorIndex = 3
Next
' 2. kleinste und 2. größte Werte Markieren
For Each Rng In Datenbereich1
If Rng = WorksheetFunction.Large(Datenbereich1, 2) Then Rng.Interior.ColorIndex = 35
If Rng = WorksheetFunction.Small(Datenbereich1, 2) Then Rng.Interior.ColorIndex = 7
Next
For Each Rng In Datenbereich2
If Rng = WorksheetFunction.Large(Datenbereich2, 2) Then Rng.Interior.ColorIndex = 35
If Rng = WorksheetFunction.Small(Datenbereich2, 2) Then Rng.Interior.ColorIndex = 7
Next
For Each Rng In Datenbereich3
If Rng = WorksheetFunction.Large(Datenbereich3, 2) Then Rng.Interior.ColorIndex = 35
If Rng = WorksheetFunction.Small(Datenbereich3, 2) Then Rng.Interior.ColorIndex = 7
Next
End Sub
Du braucht zum überprüfen von Mehreren Bereichen nicht den Befehl Intersect, sondern die Definierung der einzelnen Bereiche.
Das wird mit den Befehlen Set Datenbereich1 =Range("F5:F20") etc. gemacht.
Aber was du mit deiner Frage auf die Größte zweitgrößte und kleinste zweitkleinste meinst hab ich nicht ganz verstanden.
Bei mir werden die richtigen werte Markiert, egal ob Positive oder negative Zahl.
Es wird immer der Größte zweitgrößte oder kleinste zweitkleinste Wert markiert.
Viele Grüße aus Köln.
Anzeige
AW: Ich glaube, der ergänzte Code ist die Lösung ...
02.04.2007 09:46:13
proxima05
Hallo Mustafa,
jetzt klappt es! .... besten Dank für die tolle Unterstützung.
Gruß
Ralph
Danke für die Rückmeldung (o.T.)
02.04.2007 22:56:33
Mustafa

303 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige