xaumichi
Jul 29, 2010
view5526
view26
0
Goto Top

Tipps für VBA - Vereinfachung

GermansolvedQuestionMicrosoft OfficeMicrosoft
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
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 147893

Url: https://administrator.de/contentid/147893

Printed on: April 16, 2024 at 09:04 o'clock

26 Comments
Latest comment
Goto Top
Mitglied: 76109
76109 Jul 29, 2010 at 08:27:10 (UTC)
Goto Top
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? face-smile

Gruß Dieter
Member: xaumichi
xaumichi Jul 29, 2010 at 08:33:32 (UTC)
Goto Top
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.

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´
Mitglied: 76109
76109 Jul 29, 2010 at 09:38:23 (UTC)
Goto Top
Hallo xuamichi!

Und jetzt bitte den Code noch in Code-Tags setzenface-wink
<$code>
Dein Code
</$code>
ohne Dollarzeichen

Gruß Dieter
Mitglied: 76109
76109 Jul 29, 2010 at 10:26:47 (UTC)
Goto Top
Hallo xaumichi!

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....face-wink
Mitglied: 76109
76109 Jul 29, 2010 at 10:40:47 (UTC)
Goto Top
Hallo nochmal!

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 Sub

Gruß Dieter
Member: xaumichi
xaumichi Jul 29, 2010 at 11:01:24 (UTC)
Goto Top
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
Member: TsukiSan
TsukiSan Jul 29, 2010 at 11:02:08 (UTC)
Goto Top
Hallo xaumichi

Die ganzen Exit Sub
        Case "SEPTEMBER"  
            Range("D7").Value = "Überstd Aug."  
            Range("B8").Value = "Überstd. Sept. " & Range("E5")  
            Range("D9").Value = "Auszahlung. Aug."  
            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
Mitglied: 76109
76109 Jul 29, 2010 at 11:09:34 (UTC)
Goto Top
Hallo Mike!

Was meinst Du jetzt mit "hat nichts geholfen"?

Gruß Dieter
Member: xaumichi
xaumichi Jul 29, 2010 at 11:13:57 (UTC)
Goto Top
@ 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??
Mitglied: 76109
76109 Jul 29, 2010 at 11:21:21 (UTC)
Goto Top
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 nichtface-wink

Mal sehen, ob ich einen Fehler entdecke? Kann etwas dauern!

Gruß Dieter
Mitglied: 76109
76109 Jul 29, 2010 at 11:27:58 (UTC)
Goto Top
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
Member: xaumichi
xaumichi Jul 29, 2010 at 11:33:31 (UTC)
Goto Top
jup, das X (als Text) wird bei einer berechnung ausgegeben, wenn ein wahrheitsabfrage negativ wird . --> brauch ich bei einer Berechnung
Mitglied: 76109
76109 Jul 29, 2010 at 11:36:34 (UTC)
Goto Top
Hallo Mike!

Dann schreib es auch als Text mit Anführungszeichen = "x" Then...

Gruß Dieter
Member: xaumichi
xaumichi Jul 29, 2010 at 11:51:56 (UTC)
Goto Top
Hm...okey!

Und hättest du einen groben Fehler gefunden, der den Absturz verursachen könnte?
Mitglied: 76109
76109 Jul 29, 2010 at 15:28:56 (UTC)
Goto Top
Hallo Mike!

Habe grad nochmal durchgeschaut.

Füge in Zeile 2 diese Codezeile ein:
    If Target.Count > 1 Then Exit Sub

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 giltface-smile

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
Member: xaumichi
xaumichi Jul 29, 2010 at 17:58:20 (UTC)
Goto Top
*hihi* cool, jetzt funktionierts so, wie ich das wollte!

Danke schön für die tatkräftige Unterstützung!!

LG Mike
Mitglied: 76109
76109 Jul 29, 2010 at 19:48:48 (UTC)
Goto Top
Hallo Mike!

Yepp, gern geschehenface-wink

Gruß Dieter
Mitglied: 76109
76109 Jul 30, 2010 at 17:59:40 (UTC)
Goto Top
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.
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 Sub

Beispiel zum setzen von ColorIndex 35 (Hell/Lindgrün):
Sub WriteWoorkbookColorTable()
    
    ActiveWorkbook.Colors(35) = RGB(178, 255, 198)
    
    'oder  
    
    ActiveWorkbook.Colors(35) = &HC6FFB2
End Sub

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.
Private Sub Workbook_Open()
    With ActiveWorkbook
        .Colors(3) = RGB(255, 0, 0)
        .Colors(35) = RGB(178, 255, 198)
       '.....  
    End With
End Sub

Deinen Code habe ich mal etwas bearbeitet, in der Hoffnung, dass keine Fehler drin sindface-wink
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 Sub

Gruß Dieter
Member: xaumichi
xaumichi Jul 30, 2010 at 20:55:53 (UTC)
Goto Top
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
Mitglied: 76109
76109 Jul 31, 2010 at 12:16:21 (UTC)
Goto Top
Hallo Mike!

Zitat von @xaumichi:
Hm...wobei laut Excel-Hilfe das System mit den RGB-Werten auch funktioniert!
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 Sub
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
Member: xaumichi
xaumichi Aug 09, 2010 at 12:07:50 (UTC)
Goto Top
Hallo!

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)
schreiben??

Denn es hat sich jetzt herausgestellt, dass Office 2000/2003 das 
...Color=RGB (....)
nicht kennt! face-sad
Mitglied: 76109
76109 Aug 09, 2010 at 12:22:47 (UTC)
Goto Top
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:
Sub Test()
    Dim Farben As Variant

    Farben = ActiveWorkbook.Colors

    MsgBox UBound(Farben) 
End Sub
Bei mir sind es nur 56 Farben (Office 2002)

Gruß Dieter

PS. Und ja, diese Farbtabelle kann man ändernface-wink
Member: xaumichi
xaumichi Aug 09, 2010 at 14:02:46 (UTC)
Goto Top
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! face-smile

Oder muss ich ich mich innerhalb dieser 56 befinden?

LG
Mitglied: 76109
76109 Aug 09, 2010 at 14:35:42 (UTC)
Goto Top
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
Member: xaumichi
xaumichi Aug 09, 2010 at 14:40:55 (UTC)
Goto Top
Jup, das hab ich mir schon gesucht! face-smile Okey, danke schön!

Lg Mike
Mitglied: 76109
76109 Aug 09, 2010 at 14:46:43 (UTC)
Goto Top
Hallo Mike!

Yepp, gern geschehenface-smile

Gruß Dieter
GermansolvedQuestionMicrosoft OfficeMicrosoft