26
Tipps für VBA - Vereinfachung
Also hab ein VBA - Programm mit Change()-Ereignisse (2 Ereignisse mit if - Entscheidung, welches von beiden ausgeführt wird).
Wenn ich jedes einzeln ausführe, dass ist es kein Problem und beide funktionieren ohne Probleme.
Wenn nun beide im Change() sind, stürzt das Programm immer ab.
Ist es möglich, dass eines der Programme zu lang ist (hat ca. 250 Zeilen, mit Formatierungen und Rechnungen)
Dazu meine Frage:
Gibt es irgendwelche "Regeln" wie man ein VBA - Programm verkürzen kann?
Natürlich ist es schwer zu sagen, was man nun bei mir vereinfachen könnte, aber vl gibt es irgendwelche allgemeine Regeln.
Es wäre auch kein Problem, das betreffende File zu versenden, um sich den Code genauer anschauen zu können. (da ich den Code nicht umbedingt hier posten möchte, weil er, glaub ich, einfach zu lang ist)
LG Mike
Wenn ich jedes einzeln ausführe, dass ist es kein Problem und beide funktionieren ohne Probleme.
Wenn nun beide im Change() sind, stürzt das Programm immer ab.
Ist es möglich, dass eines der Programme zu lang ist (hat ca. 250 Zeilen, mit Formatierungen und Rechnungen)
Dazu meine Frage:
Gibt es irgendwelche "Regeln" wie man ein VBA - Programm verkürzen kann?
Natürlich ist es schwer zu sagen, was man nun bei mir vereinfachen könnte, aber vl gibt es irgendwelche allgemeine Regeln.
Es wäre auch kein Problem, das betreffende File zu versenden, um sich den Code genauer anschauen zu können. (da ich den Code nicht umbedingt hier posten möchte, weil er, glaub ich, einfach zu lang ist)
LG Mike
Auf Facebook teilen
Auf Twitter teilen
Auf Reddit teilen
Auf Linkedin teilenBitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 147893
Url: https://administrator.de/contentid/147893
Ausgedruckt am: 22.11.2024 um 20:11 Uhr
26 Kommentare
Neuester Kommentar
Hallo xaumichi!
Wäre vielleicht hilfreich, wenn Du mal Deinen Code postest, damit wir auch wissen, worum es eigentlich geht. Möglicherweise kann man den Code dann auf 1/10 kürzen?
Gruß Dieter
Wäre vielleicht hilfreich, wenn Du mal Deinen Code postest, damit wir auch wissen, worum es eigentlich geht. Möglicherweise kann man den Code dann auf 1/10 kürzen?
Gruß Dieter
hm...naja...sind halt knapp 400 Zeilen...ich weiß nicht, ob das hier erlaubt ist, einen so riesigen post zu machen?!
ansonsten wärs mir egal.
ansonsten wärs mir egal.
Private Sub Worksheet_Change(ByVal Target As Range)
'Allgemeine Formatierungen, alles Farben werden definiert, damit sie in älteren Versionen richtig erkannt werden, durch RGB-Werte
'------------------------------------------------------------
Range("G8").Font.Color = RGB(255, 151, 151)
Range("B10").Font.Color = RGB(49, 132, 132)
Range("A22", "N22").Interior.Color = RGB(192, 192, 192)
Range("A30", "N30").Interior.Color = RGB(192, 192, 192)
Range("A38", "N38").Interior.Color = RGB(192, 192, 192)
Range("A46", "N46").Interior.Color = RGB(192, 192, 192)
Range("H13", "K13").Interior.Color = RGB(178, 255, 198)
Range("H14", "K14").Interior.Color = RGB(178, 255, 198)
Range("L4", "N4").Font.Color = RGB(192, 192, 192)
Range("L5", "N5").Font.Color = RGB(192, 192, 192)
Range("L6", "N6").Font.Color = RGB(192, 192, 192)
Range("G7").Font.Color = RGB(217, 217, 217)
Range("G9").Font.Color = RGB(217, 217, 217)
Range("G10").Font.Color = RGB(217, 217, 217)
Range("L11").Font.Color = RGB(217, 217, 217)
Range("M12").Font.Color = RGB(217, 217, 217)
Range("J14", "N14").Font.Color = RGB(192, 192, 192)
'---------------------------------------------------------------------------
Dim rng1 As Range
Dim rng2 As Range
Dim isect As Range
Set rng1 = Range("A6:N53")
Set rng2 = Range("A1:N5")
Set isect = Application.Intersect(Target, rng1) 'Range1 suchen
If Not (isect Is Nothing) Then
'Überstunden gesamt formatieren
'------------------------------------------------------------------
If IsError(Range("W23")) Then
MsgBox ("Zeitfehler!" & vbCrLf & vbCrLf & "Bei der Eingabe der Zeiten ist ein Fehler aufgetreten!" & vbCrLf & "Bitte löschen Sie alle Werte der zuletzt bearbeiteten Zeile und tragen Sie die Zeiten erneut ein!"), vbCritical
Else
If Range("W23") < -0.0001 Or Range("V18") < -0.0001 Then
Range("F10").Font.Color = RGB(255, 0, 0)
Else
If Range("W23") > 0.0001 Or Range("V18") > 0.0001 And Range("W23") <> 0 Then
Range("F10").Font.Color = RGB(0, 255, 0)
Else
Range("F10").Font.Color = RGB(0, 0, 0)
End If
End If
'Überstundenübersichtstabelle, Farbformatierung!
'-------------------------------------------------------------------
If Range("F9") <= 0 Then '"Minus" bei "Auszahlung" ROT/WEISS
Range("E9").Font.Color = RGB(255, 255, 255)
Else
Range("E9").Font.Color = RGB(255, 0, 0)
End If
If Range("V19") < -0.0001 Or Range("F9") > 0 Then '"Wert" bei "Auszahlung" ROT/SCHWARZ
Range("F9").Font.Color = RGB(255, 0, 0)
Else
Range("F9").Font.Color = RGB(0, 0, 0)
End If
If Range("V16") < -0.0001 Then '"Wert Überstunden akt. Monat Rot/SCHWARZ
Range("F8").Font.Color = RGB(255, 0, 0)
Else
Range("F8").Font.Color = RGB(0, 0, 0)
End If
If Range("V16") < -0.0001 Then
Range("F8").Font.Color = RGB(255, 0, 0)
Else
Range("F8").Font.Color = RGB(0, 0, 0)
End If
If Range("Z4") - Range("V17") > 0.0001 And Range("V16") > 0.0001 Then
Range("F8").Font.Color = RGB(0, 255, 0)
End If
If Range("V15") > 0.0001 Then
Range("F7").Font.Color = RGB(0, 255, 0)
Else
If Range("V15") < -0.0001 Then
Range("F7").Font.Color = RGB(255, 0, 0)
Else
Range("F7").Font.Color = RGB(0, 0, 0)
End If
End If
'Tagesformatierung 1. Tag
'--------------------------------------------------------------------
'Sperren der Zeilen, wenn kein Datum
'--------------------------------------------------------------------
If Range("B15") = 0 Then 'Wenn kein Datum eingetrage ist
Range("C15", "G15").ClearContents 'Löscht Zelleninhalte
Range("H15", "I15").ClearContents 'Löscht Zelleninhakte
Range("C15", "N15").Locked = True 'Sperren aller Zellen, Sicherheitsmaßnahme
Range("A15", "N15").Interior.Color = RGB(192, 192, 192) 'Zeile GRAU
Range("A15").Font.Color = RGB(216, 216, 216) 'Wochentag-Schrift HELLGRAU
Range("C15", "N15").Font.Color = RGB(192, 192, 192) 'Schrift wird GRAU
Range("C15", "K15").Borders(xlInsideVertical).LineStyle = wdLineStyleNone
Exit Sub
End If
If Range("B15") <> 0 Then
Range("A15", "N15").Interior.Color = RGB(255, 255, 255) 'Zeile WEISS
Range("H15", "K15").Interior.Color = RGB(178, 254, 198) 'Sonderfehlzeiten LINDGRÜN
Range("A15").Font.Color = RGB(0, 0, 0) 'Wochentag-Schrift SCHWARZ
Range("C15", "I15").Locked = False 'Entsperren aller Zellen
Range("J15", "K15").Font.Color = RGB(178, 254, 198) 'Schriftfarbe wird wieder angepasst, LINDGRÜN
Range("L15", "N15").Font.Color = RGB(255, 255, 255) 'Schriftfarbe WEISS
Range("C15", "I15").Font.Color = RGB(0, 0, 0) 'Schriftfarbe SCHWARZ
'einblenden aller formatieren Rahmen
'-----------------------------------------------------------
With Range("C15:G15").Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Range("C15:G15").Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Range("C15:G15").Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("C15:G15").Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = -16727809
.TintAndShade = 0
.Weight = xlMedium
End With
With Range("C15:G15").Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("H15:I15").Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = -16727809
.TintAndShade = 0
.Weight = xlMedium
End With
With Range("H15:I15").Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Range("H15:I15").Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Range("H15:I15").Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0
.Weight = xlMedium
End With
With Range("H15:I15").Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0
.Weight = xlThin
End With
If Range("K15") = "Zeit!" Then 'Eingabefehler --> MINUS wird "ausgeblendet" (selbe Farbe als Hintergrund)
Range("J15").Font.Color = RGB(178, 254, 198) '"Minus" wird LINDGRÜN
End If
If IsError(Range("N15")) Then
Else
If Range("O15") = x Then
Range("N15").Font.Color = RGB(255, 255, 255)
End If
End If
If Range("K15") > 0.0001 And Range("K15") <> "Zeit!" Then 'Wenn gültige Zeit eingetragen wird,
MINUS auf ROT
Range("J15").Font.Color = RGB(255, 0, 0)
Range("K15").Font.Color = RGB(255, 0, 0) 'MINUS wird ROT
End If
If Range("K15") = "Zeit!" Then
Range("K15").Font.Color = RGB(255, 0, 0)
End If
'Ersatz, Std./Tag-Formatierung
'-------------------------------------------------------
If Range("L15") > 0 Then
Range("L15").Font.Color = RGB(0, 0, 0)
End If
If Range("L15") = "Zeit fehlt!" Then
Range("L15").Font.Color = RGB(255, 0, 0)
End If
If Range("L15") = "Eingabe!" Then
Range("L15").Font.Color = RGB(255, 0, 0)
End If
If Range("M15") >= 0 And Range("B15") > 0 Then
Range("M15").Font.Color = RGB(255, 255, 255)
End If
'Formatierung für +/- Stunden (Überstunden)
'------------------------------------------------------------
If IsError(Range("N15")) Then
Range("N15").Font.Color = RGB(255, 255, 255)
Else
If Range("L15") = "Zeit fehlt!" Then
Range("N15").Font.Color = RGB(255, 255, 255)
Else
Select Case Range("O15").Value
Case Is > 0.0001
Range("N15").Font.Color = RGB(0, 255, 0)
Case Is = x And Range("O15") <> 0
Range("N15").Font.Color = RGB(255, 255, 255)
Case Is < -0.0001
Range("N15").Font.Color = RGB(255, 0, 0)
Range("M15").Font.Color = RGB(255, 0, 0)
Case Else
Range("N15").Font.Color = RGB(0, 0, 0)
End Select
End If
End If
'Arbeitspausen Freilassen/Sperren
'-----------------------------------------------------------------------
If Range("L15") > 0 And Range("D15") = 0 And Range("F15") = 0 And Range("G15") > 0 Then
Range("D15", "F15").Interior.Color = RGB(192, 192, 192)
Range("D15", "F15").Locked = True
End If
'----------------------------------------------------------------------------------------
End If
End If
Exit Sub 'Fertig
End If
'Automatisches Schreiben der Datumsachen bei "Auszahlung" usw.
Set isect = Application.Intersect(Target, rng2) 'Range2 suchen
If Not (isect Is Nothing) Then
Select Case Range("C5").Value
Case "JÄNNER"
Range("D7").Value = "Überstd Dez."
Range("B8").Value = "Überstd. Jän. " & Range("E5")
Range("D9").Value = "Auszahlung. Dez."
Exit Sub
Case "FEBRUAR"
Range("D7").Value = "Überstd Jän."
Range("B8").Value = "Überstd. Feb. " & Range("E5")
Range("D9").Value = "Auszahlung. Jän."
Exit Sub
Case "MÄRZ"
Range("D7").Value = "Überstd Feb."
Range("B8").Value = "Überstd. März. " & Range("E5")
Range("D9").Value = "Auszahlung. Feb."
Exit Sub
Case "APRIL"
Range("D7").Value = "Überstd März."
Range("B8").Value = "Überstd. April. " & Range("E5")
Range("D9").Value = "Auszahlung. März."
Exit Sub
Case "MAI"
Range("D7").Value = "Überstd April."
Range("B8").Value = "Überstd. Mai. " & Range("E5")
Range("D9").Value = "Auszahlung. April."
Exit Sub
Case "JUNI"
Range("D7").Value = "Überstd Mai."
Range("B8").Value = "Überstd. Juni. " & Range("E5")
Range("D9").Value = "Auszahlung. Mai."
Exit Sub
Case "JULI"
Range("D7").Value = "Überstd Juni."
Range("B8").Value = "Überstd. Juli. " & Range("E5")
Range("D9").Value = "Auszahlung. Juni."
Exit Sub
Case "AUGUST"
Range("D7").Value = "Überstd Juli."
Range("B8").Value = "Überstd. Aug. " & Range("E5")
Range("D9").Value = "Auszahlung. Juli."
Exit Sub
Case "SEPTEMBER"
Range("D7").Value = "Überstd Aug."
Range("B8").Value = "Überstd. Sept. " & Range("E5")
Range("D9").Value = "Auszahlung. Aug."
Exit Sub
Case "OKTOBER"
Range("D7").Value = "Überstd Sept."
Range("B8").Value = "Überstd. Okt. " & Range("E5")
Range("D9").Value = "Auszahlung. Sept."
Exit Sub
Case "NOVEMBER"
Range("D7").Value = "Überstd Okt."
Range("B8").Value = "Überstd. Nov. " & Range("E5")
Range("D9").Value = "Auszahlung. Okt."
Exit Sub
Case "DEZEMBER"
Range("D7").Value = "Überstd Nov."
Range("B8").Value = "Überstd. Dez. " & Range("E5")
Range("D9").Value = "Auszahlung. Nov."
Exit Sub
Case Else
Range("D7").Value = "Überstd VORMMMM."
Range("B8").Value = "Überstd. MMMM. " & Range("E5")
Range("D9").Value = "Auszahlung. VORMMMM."
End Select
Exit Sub 'Fertig
End If
End Sub´
Hallo xuamichi!
Und jetzt bitte den Code noch in Code-Tags setzen
<$code>
Dein Code
</$code>
ohne Dollarzeichen
Gruß Dieter
Und jetzt bitte den Code noch in Code-Tags setzen
<$code>
Dein Code
</$code>
ohne Dollarzeichen
Gruß Dieter
Hallo xaumichi!
Hier mal ein Beispiel, wie Du in Deinem Change-Code die 192er Farben mit nur einer Codezeile initialisierst:
Gruß Dieter
PS. Das gleiche Prinzip kannst Du auch bei den Borders anwenden....
Hier mal ein Beispiel, wie Du in Deinem Change-Code die 192er Farben mit nur einer Codezeile initialisierst:
Range("A22:N22,A30:N30,A38:N38,A46:N46").Interior.Color = RGB(192, 192, 192) Gruß Dieter
PS. Das gleiche Prinzip kannst Du auch bei den Borders anwenden....
Hallo nochmal!
Und hier der Code, wie Du das Change-Erreignis austricksen kannst:
Gruß Dieter
Und hier der Code, wie Du das Change-Erreignis austricksen kannst:
Dim NoChange As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
If NoChange = True Then Exit Sub
NoChange = True
'Hier der Code der ausgeführt werden soll, bei dem das Change-Erreignis übersprungen werden soll
NoChange = False
'Hier der Code der beim Change-Erreignis ausgeführt werden soll
End SubGruß Dieter
hm...danke mal dafür!
Hab die zeilen mal zusammengekürzt, hat jedoch nichts geholfen.
hm....die letzten zeilen die du geschickt hast versteh ich irgendwie nicht.... :-S
LG mike
Hab die zeilen mal zusammengekürzt, hat jedoch nichts geholfen.
hm....die letzten zeilen die du geschickt hast versteh ich irgendwie nicht.... :-S
LG mike
Hallo xaumichi
Die ganzen Exit Sub
in den einzelnen Case-Abfragen kannst du auch entfernen.
Am Ende (direkt nach der Select-Case-Anweisung) steht es ja schon da.
Das spart auch noch ein paar Zeilen.
Gruss
Tsuki
Die ganzen Exit Sub
Case "SEPTEMBER"
Range("D7").Value = "Überstd Aug."
Range("B8").Value = "Überstd. Sept. " & Range("E5")
Range("D9").Value = "Auszahlung. Aug."
Exit SubAm Ende (direkt nach der Select-Case-Anweisung) steht es ja schon da.
Das spart auch noch ein paar Zeilen.
Gruss
Tsuki
Hallo Mike!
Was meinst Du jetzt mit "hat nichts geholfen"?
Gruß Dieter
Was meinst Du jetzt mit "hat nichts geholfen"?
Gruß Dieter
@ TsukiSan: jup, habe ich schon gemacht!
@ didi1954: Ich habe die Range zusammengefasst, aber das Programm stürzt noch immer ab.
Leider weiß ich nicht wieso!
Ist da doch wo ein Programmierfehler (hat es was mit den 2 Ereignissen zu tun) oder sind die Procedures einfach nur zu lang??
@ didi1954: Ich habe die Range zusammengefasst, aber das Programm stürzt noch immer ab.
Leider weiß ich nicht wieso!
Ist da doch wo ein Programmierfehler (hat es was mit den 2 Ereignissen zu tun) oder sind die Procedures einfach nur zu lang??
Hallo Mike!
Achso, da habe ich jetzt noch garnicht nachgeschaut. War jetzt irgendwie zu sehr auf's optimieren fixiert. Aber an der Code-Länge liegt es sicherlich nicht
Mal sehen, ob ich einen Fehler entdecke? Kann etwas dauern!
Gruß Dieter
Achso, da habe ich jetzt noch garnicht nachgeschaut. War jetzt irgendwie zu sehr auf's optimieren fixiert. Aber an der Code-Länge liegt es sicherlich nicht
Mal sehen, ob ich einen Fehler entdecke? Kann etwas dauern!
Gruß Dieter
Hallo Mike!
Tausch mal die Word-Konstante "wdLineStyleNone" in Zeile 104 gegen "xlNone" aus
Und was soll z.B. in Zeile 190 "= x Then" bedeuten, Textzeichen "x" oder was?
in Zeile 196 fehlt das Kommentarzeichen vor dem "MINUS auf Rot" bzw hat sich wohl ein Zeilenvorschub eingeschlichen?
Gruß Dieter
Tausch mal die Word-Konstante "wdLineStyleNone" in Zeile 104 gegen "xlNone" aus
Und was soll z.B. in Zeile 190 "= x Then" bedeuten, Textzeichen "x" oder was?
in Zeile 196 fehlt das Kommentarzeichen vor dem "MINUS auf Rot" bzw hat sich wohl ein Zeilenvorschub eingeschlichen?
Gruß Dieter
jup, das X (als Text) wird bei einer berechnung ausgegeben, wenn ein wahrheitsabfrage negativ wird . --> brauch ich bei einer Berechnung
Hallo Mike!
Dann schreib es auch als Text mit Anführungszeichen = "x" Then...
Gruß Dieter
Dann schreib es auch als Text mit Anführungszeichen = "x" Then...
Gruß Dieter
Hm...okey!
Und hättest du einen groben Fehler gefunden, der den Absturz verursachen könnte?
Und hättest du einen groben Fehler gefunden, der den Absturz verursachen könnte?
Hallo Mike!
Habe grad nochmal durchgeschaut.
Füge in Zeile 2 diese Codezeile ein:
Dadurch wird verhindert, das ein erneutes Change-Erreignis mit mehr als einer Zelle bearbeitet wird. Codezeile 98 und 99 wären z.B. so ein Fall und führen letztendlich zu einem Absturz.
Ansonsten musst Du sicherstellen, dass Deine Change-Routinen nur ausgeführt wird, wenn die Variable Target nur 1 Zell-Adresse enthält und keine Zell-Bereiche. Das gilt für Codezeilen genauso, wie für Aktionen im Tabellenblatt, wenn z.B. mehrere Zellen markiert sind und Du die Entfernen-Taste betätigst.
Die Verwendung von Erreignis-Aufrufe haben so Ihre Seiteneffekte und Tücken, die es zu berücksichtigen gilt
Bei Änderungen des Zellinhaltes innerhalb von Codezeilen, kannst Du mit meinem Beispiel der NoChange-Methode einen ungewollten erneuten Erreignis-Aufruf einfach verhindern bzw abbrechen.
Gruß Dieter
Habe grad nochmal durchgeschaut.
Füge in Zeile 2 diese Codezeile ein:
If Target.Count > 1 Then Exit SubDadurch wird verhindert, das ein erneutes Change-Erreignis mit mehr als einer Zelle bearbeitet wird. Codezeile 98 und 99 wären z.B. so ein Fall und führen letztendlich zu einem Absturz.
Ansonsten musst Du sicherstellen, dass Deine Change-Routinen nur ausgeführt wird, wenn die Variable Target nur 1 Zell-Adresse enthält und keine Zell-Bereiche. Das gilt für Codezeilen genauso, wie für Aktionen im Tabellenblatt, wenn z.B. mehrere Zellen markiert sind und Du die Entfernen-Taste betätigst.
Die Verwendung von Erreignis-Aufrufe haben so Ihre Seiteneffekte und Tücken, die es zu berücksichtigen gilt
Bei Änderungen des Zellinhaltes innerhalb von Codezeilen, kannst Du mit meinem Beispiel der NoChange-Methode einen ungewollten erneuten Erreignis-Aufruf einfach verhindern bzw abbrechen.
Gruß Dieter
*hihi* cool, jetzt funktionierts so, wie ich das wollte!
Danke schön für die tatkräftige Unterstützung!!
LG Mike
Danke schön für die tatkräftige Unterstützung!!
LG Mike
Hallo Mike!
Yepp, gern geschehen
Gruß Dieter
Yepp, gern geschehen
Gruß Dieter
Hallo Mike!
Zu dem Thema Zellfarben ist mir noch eingefallen, dass ein direktes beliebiges setzen per RGB-Werte für Zellen nicht funktioniert. Für jede Zellfarbe muss ein ColorIndex existieren. D.h. Excel akzeptiert nur Zellfarben, die in der Workbook-Farbtabelle vorhanden sind (Optionen, Farben), die allerdings geändert werden können.
Wenn Du nun versuchst, bei einer Zelle einen beliebigen Farbwert festzulegen, dann ändert Excel automatisch die Farbe auf eine Farbe mit einem gültigen ColorIndex, wobei dann offensichtlich per Vergleich eine Farbe gewählt wird, die dem Farbwert am ähnlichsten ist.
Das bedeutet, wenn Du eine vorliebe für bestimmte Farben hast, dann musst Du Workbook-Farbtabelle entsprechend anpassen.
Mit nachfolgendem Codebeispiel kannst Du die Workbook-Farbtabelle auslesen, wobei die ColorIndex-Nummern nicht fortlaufend den Farben in der Tabelle zugeordnet sind. Von daher, wird die Farbe in Range("A1:B2") des aktiven Tabellenblatts angezeigt, der ColorIndex und die Hex- und RGB-Werte werden per MsgBox ausgegeben, wobei die Hexwerte als BGR gelesen werden müssen.
Beispiel zum setzen von ColorIndex 35 (Hell/Lindgrün):
Demnach kannst Du in Deinem Code anstatt der RGB-Werte den ColorIndex verwenden und die Workbook-Farben entsprechen initialisieren, wobei ich das über die Workbook_Open-Funktion in "Diese Arbeitsmappe" machen würde z.B.
Deinen Code habe ich mal etwas bearbeitet, in der Hoffnung, dass keine Fehler drin sind
Gruß Dieter
Zu dem Thema Zellfarben ist mir noch eingefallen, dass ein direktes beliebiges setzen per RGB-Werte für Zellen nicht funktioniert. Für jede Zellfarbe muss ein ColorIndex existieren. D.h. Excel akzeptiert nur Zellfarben, die in der Workbook-Farbtabelle vorhanden sind (Optionen, Farben), die allerdings geändert werden können.
Wenn Du nun versuchst, bei einer Zelle einen beliebigen Farbwert festzulegen, dann ändert Excel automatisch die Farbe auf eine Farbe mit einem gültigen ColorIndex, wobei dann offensichtlich per Vergleich eine Farbe gewählt wird, die dem Farbwert am ähnlichsten ist.
Das bedeutet, wenn Du eine vorliebe für bestimmte Farben hast, dann musst Du Workbook-Farbtabelle entsprechend anpassen.
Mit nachfolgendem Codebeispiel kannst Du die Workbook-Farbtabelle auslesen, wobei die ColorIndex-Nummern nicht fortlaufend den Farben in der Tabelle zugeordnet sind. Von daher, wird die Farbe in Range("A1:B2") des aktiven Tabellenblatts angezeigt, der ColorIndex und die Hex- und RGB-Werte werden per MsgBox ausgegeben, wobei die Hexwerte als BGR gelesen werden müssen.
Sub ReadWorkbookColorTable()
Dim Farbtabelle As Variant, Index As Integer, strHEX As String, strRGB As String
Farbtabelle = ActiveWorkbook.Colors 'Farbtabelle ist Long-Array von 1 - 56
For Index = 1 To UBound(Farbtabelle)
Range("A1:B2").Interior.ColorIndex = Index
strHEX = Right("00000" & Hex(Farbtabelle(Index)), 6)
strRGB = Right("00" & CInt("&H" & Mid(strHEX, 5, 2)), 3) & "," & _
Right("00" & CInt("&H" & Mid(strHEX, 3, 2)), 3) & "," & _
Right("00" & CInt("&H" & Mid(strHEX, 1, 2)), 3)
If MsgBox("ColorIndex " & Right("0" & Index, 2) & ": HEX(" & strHEX & ") RGB (" & strRGB & ")", vbOKCancel) = vbCancel Then Exit For
Next
End SubBeispiel zum setzen von ColorIndex 35 (Hell/Lindgrün):
Sub WriteWoorkbookColorTable()
ActiveWorkbook.Colors(35) = RGB(178, 255, 198)
'oder
ActiveWorkbook.Colors(35) = &HC6FFB2
End SubDemnach kannst Du in Deinem Code anstatt der RGB-Werte den ColorIndex verwenden und die Workbook-Farben entsprechen initialisieren, wobei ich das über die Workbook_Open-Funktion in "Diese Arbeitsmappe" machen würde z.B.
Private Sub Workbook_Open()
With ActiveWorkbook
.Colors(3) = RGB(255, 0, 0)
.Colors(35) = RGB(178, 255, 198)
'.....
End With
End SubDeinen Code habe ich mal etwas bearbeitet, in der Hoffnung, dass keine Fehler drin sind
Option Explicit
Dim NoChange As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Or NoChange = True Then Exit Sub
Range("A22:N22,A30:N30,A38:N38,A46:N46").Interior.Color = RGB(192, 192, 192)
Range("H13:K14,A30:N30,A38:N38,A46:N46").Interior.Color = RGB(178, 255, 198)
Range("B10").Font.Color = RGB(49, 132, 132)
Range("G7,G9,G10,L11,M12").Font.Color = RGB(217, 217, 217)
Range("G8").Font.Color = RGB(255, 151, 151)
Range("L4:N6,J14:N14").Font.Color = RGB(192, 192, 192)
Dim rng1 As Range
Dim rng2 As Range
Dim isect As Range
Set rng1 = Range("A6:N53")
Set rng2 = Range("A1:N5")
Set isect = Application.Intersect(Target, rng1) 'Range1 suchen
If Not isect Is Nothing Then
If IsError(Range("W23")) Then
MsgBox ("Zeitfehler!" & vbCrLf & vbCrLf & "Bei der Eingabe der Zeiten ist ein Fehler aufgetreten!" & vbCrLf & "Bitte löschen Sie alle Werte der zuletzt bearbeiteten Zeile und tragen Sie die Zeiten erneut ein!"), vbCritical
Else
If Range("W23") < -0.0001 Or Range("V18") < -0.0001 Then
Range("F10").Font.Color = 3 'RGB(255, 0, 0)
ElseIf Range("W23") > 0.0001 Or Range("V18") > 0.0001 And Range("W23") <> 0 Then
Range("F10").Font.Color = RGB(0, 255, 0)
Else
Range("F10").Font.Color = RGB(0, 0, 0)
End If
If Range("F9") <= 0 Then
Range("E9").Font.Color = RGB(255, 255, 255)
Else
Range("E9").Font.Color = RGB(255, 0, 0)
End If
If Range("V19") < -0.0001 Or Range("F9") > 0 Then
Range("F9").Font.Color = RGB(255, 0, 0)
Else
Range("F9").Font.Color = RGB(0, 0, 0)
End If
If Range("V16") < -0.0001 Then
Range("F8").Font.Color = RGB(255, 0, 0)
Else
Range("F8").Font.Color = RGB(0, 0, 0)
End If
If Range("Z4") - Range("V17") > 0.0001 And Range("V16") > 0.0001 Then
Range("F8").Font.Color = RGB(0, 255, 0)
End If
If Range("V15") > 0.0001 Then
Range("F7").Font.Color = RGB(0, 255, 0)
ElseIf Range("V15") < -0.0001 Then
Range("F7").Font.Color = RGB(255, 0, 0)
Else
Range("F7").Font.Color = RGB(0, 0, 0)
End If
If Range("B15") = 0 Then
NoChange = True
Range("C15:G15,H15:I15").ClearContents
NoChange = False
Range("C15:N15").Locked = True
Range("A15").Font.Color = RGB(216, 216, 216)
Range("C15:N15").Font.Color = RGB(192, 192, 192)
Range("A15:N15").Interior.Color = RGB(192, 192, 192)
Range("C15:K15").Borders(xlInsideVertical).LineStyle = xlNone
Exit Sub
Else
Range("C15:I15").Locked = False
Range("A15").Font.Color = RGB(0, 0, 0)
Range("C15:I15").Font.Color = RGB(0, 0, 0)
Range("J15:K15").Font.Color = RGB(178, 254, 198)
Range("L15:N15").Font.Color = RGB(255, 255, 255)
Range("A15:N15").Interior.Color = RGB(255, 255, 255)
Range("H15:K15").Interior.Color = RGB(178, 254, 198)
With Range("C15:G15")
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Color = -16727809
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
With Range("H15:I15")
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Color = -16727809
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0
.Weight = xlMedium
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ThemeColor = 2
.TintAndShade = 0
.Weight = xlThin
End With
End With
If Range("K15") = "Zeit!" Then
Range("J15").Font.Color = RGB(178, 254, 198)
End If
If IsError(Range("N15")) Then
'?
ElseIf Range("O15") = "x" Then
Range("N15").Font.Color = RGB(255, 255, 255)
End If
If Range("K15") > 0.0001 And Range("K15") <> "Zeit!" Then
Range("J15:K15").Font.Color = RGB(255, 0, 0)
ElseIf Range("K15") = "Zeit!" Then
Range("K15").Font.Color = RGB(255, 0, 0)
End If
If IsNumeric(Range("L15")) And Range("L15") > 0 Then
Range("L15").Font.Color = RGB(0, 0, 0)
ElseIf Range("L15") = "Zeit fehlt!" Then
Range("L15").Font.Color = RGB(255, 0, 0)
ElseIf Range("L15") = "Eingabe!" Then
Range("L15").Font.Color = RGB(255, 0, 0)
End If
If Range("M15") >= 0 And Range("B15") > 0 Then
Range("M15").Font.Color = RGB(255, 255, 255)
End If
If IsError(Range("N15")) Then
Range("N15").Font.Color = RGB(255, 255, 255)
ElseIf Range("L15") = "Zeit fehlt!" Then
Range("N15").Font.Color = RGB(255, 255, 255)
Else
Select Case Range("O15").Value
Case Is > 0.0001
Range("N15").Font.Color = RGB(0, 255, 0)
Case Is = "x" And Range("O15") <> 0
Range("N15").Font.Color = RGB(255, 255, 255)
Case Is < -0.0001
Range("N15:M15").Font.Color = RGB(255, 0, 0)
Case Else
Range("N15").Font.Color = RGB(0, 0, 0)
End Select
End If
If Range("L15") > 0 And Range("D15") = 0 And Range("F15") = 0 And Range("G15") > 0 Then
Range("D15:F15").Interior.Color = RGB(192, 192, 192)
Range("D15:F15").Locked = True
End If
End If
End If
Exit Sub
End If
Set isect = Application.Intersect(Target, rng2)
If Not (isect Is Nothing) Then
Select Case Range("C5").Value
Case "JÄNNER"
Call SetAuszahlungsdatum("Dez,Jän,Dez")
Case "FEBRUAR"
Call SetAuszahlungsdatum("Jän,Feb,Jän")
Case "MÄRZ"
Call SetAuszahlungsdatum("Feb,März,Feb")
Case "APRIL"
Call SetAuszahlungsdatum("März,April,März")
Case "MAI"
Call SetAuszahlungsdatum("April,Mai,April")
Case "JUNI"
Call SetAuszahlungsdatum("Mai,Juni,Mai")
Case "JULI"
Call SetAuszahlungsdatum("Juni,Juli,Juni")
Case "AUGUST"
Call SetAuszahlungsdatum("Juli,Aug,Juli")
Case "SEPTEMBER"
Call SetAuszahlungsdatum("Aug,Sept,Aug")
Case "OKTOBER"
Call SetAuszahlungsdatum("Sept,Okt,Sept")
Case "NOVEMBER"
Call SetAuszahlungsdatum("Okt,Nov,Okt")
Case "DEZEMBER"
Call SetAuszahlungsdatum("Nov,Dez,Nov")
Case Else
Call SetAuszahlungsdatum("VORMMMM,MMMM,VORMMMM")
End Select
End If
End Sub
Private Sub SetAuszahlungsdatum(ByRef T)
Dim M As Variant
NoChange = True
M = Split(T, ",")
Range("D7") = "Überstd. " & M(0) & "."
Range("B8") = "Überstd. " & M(1) & ". " & Range("E5")
Range("D9") = "Auszahlung " & M(2) & "."
NoChange = False
End SubGruß Dieter
Also jetzt nochmal ein GROOOSSSES WOW! Vielen dank!!
Muss ich gleich mal ausprobieren! :D
Hm...wobei laut Excel-Hilfe das System mit den RGB-Werten auch funktioniert!
Okey, aber gut zu wissen. Dann muss ich mir das mitn Index nochmal anschauen.
Vielen Dank!
LG Mike
Muss ich gleich mal ausprobieren! :D
Hm...wobei laut Excel-Hilfe das System mit den RGB-Werten auch funktioniert!
Okey, aber gut zu wissen. Dann muss ich mir das mitn Index nochmal anschauen.
Vielen Dank!
LG Mike
Hallo Mike!
Auf jedenfall bei Shape-Objecten, UserForms.... Die Anwendung auf Zellen funktioniert zumindest bei meiner Excel-Version nicht.
In der Hoffnung, das die Performance nicht zu sehr beinträchtigt wird, noch eine Möglichkeit die Bordergeschichte etwas zu reduzieren:
wobei bei meiner ExcelVersion die Objecte "TintAndShade" und "ThemeColor" nicht zur Verfügung stehen, daher Kommentarzeichen.
Die Farbangaben werden per String übergeben und sind wie folgt definiert:
"I=Wert" - .ColorIndex = Dezimalzahl (Beispiel: "I=35")
"H=Wert" - .Color = Hexadezimal (Beispiel: "H=FFFFFF")
"R=Wert" - .Color = RGB-Array ("R=255,255,255")
"T=Wert" - .ThemeColor = Dezimalzahl (Beispiel: "T=2")
Gruß Dieter
Auf jedenfall bei Shape-Objecten, UserForms.... Die Anwendung auf Zellen funktioniert zumindest bei meiner Excel-Version nicht.
In der Hoffnung, das die Performance nicht zu sehr beinträchtigt wird, noch eine Möglichkeit die Bordergeschichte etwas zu reduzieren:
'snip.........................
With Range("C15:G15")
Call SetBorders(.Address, xlEdgeLeft, "I=0", xlMedium)
Call SetBorders(.Address, xlEdgeTop, "I=0", xlMedium)
Call SetBorders(.Address, xlEdgeBottom, "I=0", xlThin)
Call SetBorders(.Address, xlEdgeRight, "H=FF00C0FF", xlMedium) 'FF00C0FF = -16727809
Call SetBorders(.Address, xlInsideVertical, "I=0", xlThin)
End With
With Range("H15:I15")
Call SetBorders(.Address, xlEdgeLeft, "H=FF00C0FF", xlMedium) 'FF00C0FF = -16727809
Call SetBorders(.Address, xlEdgeTop, "I=0", xlMedium)
Call SetBorders(.Address, xlEdgeBottom, "I=0", xlThin)
Call SetBorders(.Address, xlEdgeRight, "T=2", xlMedium)
Call SetBorders(.Address, xlInsideVertical, "T=2", xlThin)
End With
'snip.........................
Private Sub SetBorders(ByRef Rng, ByVal Pos As Long, ByRef Color, ByVal Weight As Long)
Dim ColorCmd As Variant, ColorRGB As Variant
ColorCmd = Split(Color, "=")
With Range(Rng).Borders(Pos)
.LineStyle = xlContinuous
.Weight = Weight
'.TintAndShade = 0
If ColorCmd(0) = "I" Then
.ColorIndex = CLng(ColorCmd(1))
ElseIf ColorCmd(0) = "H" Then
.Color = CLng("&H" & ColorCmd(1))
ElseIf ColorCmd(0) = "T" Then
'.ThemeColor = CLng(ColorCmd(1))
ElseIf ColorCmd(0) = "R" Then
ColorRGB = Split(ColorCmd(1), ",")
.Color = RGB(CInt(ColorRGB(0)), CInt(ColorRGB(1)), CInt(ColorRGB(2)))
End If
End With
End SubDie Farbangaben werden per String übergeben und sind wie folgt definiert:
"I=Wert" - .ColorIndex = Dezimalzahl (Beispiel: "I=35")
"H=Wert" - .Color = Hexadezimal (Beispiel: "H=FFFFFF")
"R=Wert" - .Color = RGB-Array ("R=255,255,255")
"T=Wert" - .ThemeColor = Dezimalzahl (Beispiel: "T=2")
Gruß Dieter
Hallo!
Kann ich mit diesem Code hier:
neue Farben initialisieren, oder wie?
Un dem ich zB.: dann schreiben??
Denn es hat sich jetzt herausgestellt, dass Office 2000/2003 das nicht kennt! 
Kann ich mit diesem Code hier:
Sub WriteWoorkbookColorTable()
ActiveWorkbook.Colors(35) = RGB(178, 255, 198)
'oder
ActiveWorkbook.Colors(35) = &HC6FFB2
End Sub neue Farben initialisieren, oder wie?
Un dem ich zB.: dann
...Color(111) = RGB(219, 291, 219) Denn es hat sich jetzt herausgestellt, dass Office 2000/2003 das
...Color=RGB (....)
Hallo Mike!
Mhm, wieviele Farben hat denn Deine Farbtabelle <Optionen><Farben>? Gibt es da tatsächlich 111 Farben oder mehr?
Oder mit diesem Code anzeigen lassen:
Bei mir sind es nur 56 Farben (Office 2002)
Gruß Dieter
PS. Und ja, diese Farbtabelle kann man ändern
Mhm, wieviele Farben hat denn Deine Farbtabelle <Optionen><Farben>? Gibt es da tatsächlich 111 Farben oder mehr?
Oder mit diesem Code anzeigen lassen:
Sub Test()
Dim Farben As Variant
Farben = ActiveWorkbook.Colors
MsgBox UBound(Farben)
End SubGruß Dieter
PS. Und ja, diese Farbtabelle kann man ändern
Naja, darum hätte ich irgend einen hohen Wert genommen, damit ich keine andere Farbe "überschreibe" oder so.
Darum hab ich einfach mal "111" angenommen, denn da wär ich sicher darüber gewesen!
Oder muss ich ich mich innerhalb dieser 56 befinden?
LG
Darum hab ich einfach mal "111" angenommen, denn da wär ich sicher darüber gewesen!
Oder muss ich ich mich innerhalb dieser 56 befinden?
LG
Hallo Mike!
Da 111 ein ungültiger Wert ist, ergibt das dann natürlich einen Object-Fehler, den Du dann auf das RGB bezogen hast.
D.h. Du musst schon einen gültigen Wert zwischen 1-56 eingeben, wobei es sinnvoll ist, die letzten 16 Farben neu zu definieren . Diese Farben sind speziell für Chart's gedacht. Wenn Du in Deinem Tabellenblatt die Füllfarben ansiehst, dann wird Dir auffallen, dass hier nur 48 Farben zur Verfügung stehen. Aber Achtung, die Zählreihenfolge (IndexNummer) stimmt nicht mit der Zählung der Farbfelder überein. Da habe ich in einem anderen Deiner Beiträge aber schon darauf hingewiesen. Z.B. ist die Farbe Rot (IndexNummer 3) im Farbfeld erst an Stelle 17... die letzten 16 Farben <Optionen><Farben> haben, wenn ich mich recht erinnere die IndexNummer ab 24
Gruß Dieter
Da 111 ein ungültiger Wert ist, ergibt das dann natürlich einen Object-Fehler, den Du dann auf das RGB bezogen hast.
D.h. Du musst schon einen gültigen Wert zwischen 1-56 eingeben, wobei es sinnvoll ist, die letzten 16 Farben neu zu definieren . Diese Farben sind speziell für Chart's gedacht. Wenn Du in Deinem Tabellenblatt die Füllfarben ansiehst, dann wird Dir auffallen, dass hier nur 48 Farben zur Verfügung stehen. Aber Achtung, die Zählreihenfolge (IndexNummer) stimmt nicht mit der Zählung der Farbfelder überein. Da habe ich in einem anderen Deiner Beiträge aber schon darauf hingewiesen. Z.B. ist die Farbe Rot (IndexNummer 3) im Farbfeld erst an Stelle 17... die letzten 16 Farben <Optionen><Farben> haben, wenn ich mich recht erinnere die IndexNummer ab 24
Gruß Dieter
Jup, das hab ich mir schon gesucht! Okey, danke schön!
Lg Mike
Okey, danke schön!Lg Mike
Hallo Mike!
Yepp, gern geschehen
Gruß Dieter
Yepp, gern geschehen
Gruß Dieter
