VBA Code optimieren

Computer: Software & Programmierung Programmierung allgemein
#1

Hallo liebe Spezialisten - Gemeinde
Ich habe mir in Excel 2003 einen Code im Tabellenblatt geschrieben, welcher folgendes bewirkt: 1.) Bei Texteintrag „Urlaub“, „Krank“ bzw. „Za“ in Zelle „D4“ wird der Inhalt aus der Zeile „E4“ bis „M4“ gelöscht.
2.) Sodann je nach Eintrag grün, blau oder rot eingefärbt und zwar von „B4“ bis „M4“.
3.) Und zu guter letzt wird der Zellenrahmen entfern und nur noch  „Rahmenlinien außen“ „B4“ bis „M4“ erzeugt.
Ich bin zufrieden da er klaglos funktioniert, aber ich bin mir nicht sicher ob er auch optimal ist, da er mir doch recht lange vorkommt und ich den Code noch um einige Ereignisse erweitern möchte. Also würde ich euch Profis darum bitten meinen Code etwas zu kürzen, wenn dies möglich ist. Wenn Ja, dann bitte mit Kommentare, da ich ihn wie gesagt erweitern möchte. Herzlichen Dank und schone Grüße aus Wien.

Hier der VBA Code:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Cells.Count > 4 Then Exit Sub
  Select Case Target.Value
    Case „Krank“                                                                
      Range(Cells(Target.Row, 5), Cells(Target.Row, 13)).ClearContents            
      Range(Cells(Target.Row, 2), Cells(Target.Row, 13)).Interior.ColorIndex = 3  
      Range(Cells(Target.Row, 2), Cells(Target.Row, 13)).Select                   
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
   
Case „Za“
      Range(Cells(Target.Row, 5), Cells(Target.Row, 13)).ClearContents
      Range(Cells(Target.Row, 2), Cells(Target.Row, 13)).Interior.ColorIndex = 5
      Range(Cells(Target.Row, 2), Cells(Target.Row, 13)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
   
Case „Urlaub“
      Range(Cells(Target.Row, 5), Cells(Target.Row, 13)).ClearContents
      Range(Cells(Target.Row, 2), Cells(Target.Row, 13)).Interior.ColorIndex = 4
      Range(Cells(Target.Row, 2), Cells(Target.Row, 13)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone

'FREI FUER WEITERE BEDINGUNGEN
’    Case „AllesRot“
’       Range(Cells(Target.Row, 5), Cells(Target.Row, 13)).ClearContents
’       Range(Cells(Target.Row, 4), Cells(Target.Row, 13)).Interior.ColorIndex = 4
Case Else
      Rows(Target.Row).Interior.ColorIndex = 2
  End Select
End Sub

#2

Hi,

ich habe mir das mal grob angeschaut.
Prinzipiell kannst du alle identischen Codezeilen außerhalb vom Select unterbringen.
Mir ist jetzt nur der Colorindex aufgefallen, der unterschiedlich ist - das habe ich über eine eigene variable dynamisch zugewiesen.

Weiterhin gibt es noch die Variable allesOk, die per Default auf true gesetzt ist und sich auf false ändert, wenn kein select-Kriterium zutrifft.

Der kürze, aber identische Code wäre u.g.

Gruss,
Andi

________________________________________
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Cells.Count > 4 Then Exit Sub

    dim allesOk as boolean = true
    dim iColorIndex as integer  =0
    
  Select Case Target.Value
    Case „Krank“      
          iColorIndex =3
 
   Case „Za“
        iColorIndex=5    
    
    Case „Urlaub“
        iColorIndex =4
        Rows(Target.Row).Interior.ColorIndex = 2
        
    case else
           allesOk = true
  End Select
 
  if allesOk=true then
      Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        
          Range(Cells(Target.Row, 5), Cells(Target.Row, 13)).ClearContents            
          Range(Cells(Target.Row, 2), Cells(Target.Row, 13)).Interior.ColorIndex = iColorIndex
          Range(Cells(Target.Row, 2), Cells(Target.Row, 13)).Select                   

         With Selection.Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
            With Selection.Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
    end if      
End Sub
________________________________________

#3

Ich bin zufrieden da er klaglos funktioniert, aber ich bin mir
nicht sicher ob er auch optimal ist, da er mir doch recht
lange vorkommt und ich den Code noch um einige Ereignisse
erweitern möchte. Also würde ich euch Profis darum bitten
meinen Code etwas zu kürzen, wenn dies möglich ist. Wenn Ja,
dann bitte mit Kommentare, da ich ihn wie gesagt erweitern
möchte. Herzlichen Dank und schone Grüße aus Wien.

Hallo Wiener,

probiere mal diesen Code
Gruß
Reinhard

Option Explicit

Private Sub Worksheet\_Change(ByVal Target As Excel.Range)
Dim arrWert, arrFarbe, N As Integer, Vorh As Boolean
arrWert = Array("Krank", "Za", "Urlaub")
arrFarbe = Array(3, 5, 4)
If Target.Cells.Count \> 4 Then Exit Sub
If Target.Count \> 1 Then Exit Sub 'Ausstieg wenn mehrere Zellen gleichzeitig abgeändert wurden
For N = LBound(arrWert) To UBound(arrWert) 'Elemente von arrWert wird mit Target verglichen
 If Target.Value = arrWert(N) Then 'ist Target in dem arrWert
 Vorh = True 'wird Vorh auf True gesetzt
 Exit For 'und die Forschleife verlassen
 End If
Next N
If Vorh Then 'Überprüfung ob Vorh auf True gesetzt ist
 Range(Cells(Target.Row, 5), Cells(Target.Row, 13)).ClearContents
 With Range(Cells(Target.Row, 2), Cells(Target.Row, 13))
 .Interior.ColorIndex = arrFarbe(N)
 .Borders(xlDiagonalDown).LineStyle = xlNone
 .Borders(xlDiagonalUp).LineStyle = xlNone
 For N = 7 To 10 '7=xlEdgeLeft, 8=xlEdgeTop, usw.
 With .Borders(N)
 .LineStyle = xlContinuous
 .Weight = xlThin
 .ColorIndex = xlAutomatic
 End With
 Next N
 End With
Else 'wenn Vorh False war
 Rows(Target.Row).Interior.ColorIndex = 2
End If
End Sub
#4

Danke Reinhard, Danke Andi beide Codes laufen optimal werde an beiden meine erdachten Erweiterungen probieren. Superrrrr Happpppie.

#5

Danke Reinhard, Danke Andi beide Codes laufen optimal werde an
beiden meine erdachten Erweiterungen probieren. Superrrrr
Happpppie.

Hallo Wiener Würstchen *gg*,

ich sehe im Code von Andreas einige Ungereimten, m.E. kann der Code gar nicht optimal laufen… Zeige mir bitte hier mal deinen Andreas-Code den du getestet hast.

In der ersten Codezeile hast du sicher > in > geändert, okay.
Was hast du mit den beiden Dim-Zeilen gemacht?

Gruß
Reinhard, aus Frankfurt, deshalb das mit dem Würstchen :smile: