Checkboxen abfragen und Ampelsystem

  • Excel

    Checkboxen abfragen und Ampelsystem

    Hallo zusammen,

    vorweg möchte ich sagen, dass ich überhaupt kein VBA-Kenner bin und mir die Programmteile zum grössten Teil zusammensuche und meinen Bedürfnissen anpasse.
    Der Programmcode läuft soweit auch durch, jedoch ist die Schnelligkeit misserabel.

    Im Excel-File gibt es zwei Blätter mit jeweils ca. 150 Checkboxen, welche mit der jeweiligen Zelle verknüpft werden müssen.

    Dies erfolgt beim Öffnen der Datei:

    Visual Basic-Quellcode

    1. For Each WsTab In Worksheets
    2. If WsTab.Name = "HP-Fakturierung" Or WsTab.Name = "Monatsfakturierung" Then
    3. WsTab.Activate
    4. For Each chkElement In ActiveSheet.CheckBoxes
    5. chkElement.LinkedCell = chkElement.TopLeftCell.Address
    6. Next chkElement
    7. End If
    8. Next WsTab


    Beim Aktivieren einer Checkbox wird in der rechten Zelle davon das Datum und der Username angegeben.
    Dieser Code ist in einem Modul.

    Visual Basic-Quellcode

    1. Sub CheckBox_Date_Stamp()
    2. Dim xChk As CheckBox
    4. Set xChk = ActiveSheet.CheckBoxes(Application.Caller)
    6. With xChk.TopLeftCell.Offset(, 1)
    7. If xChk.Value = xlOff Then
    8. .Value = ""
    9. Else
    10. .Value = " " & Date & " " & Application.UserName
    12. End If
    13. End With
    15. End Sub


    Nun wird abgefragt, ob sich in der Zelle rechts von der obigen Checkbox etwas ändert (-> Eingabe von Datum und Username).
    Wenn ja, dann wird folgender Code ausgeführt:
    HIer werden alle Zellen ab Zeile 9 bis unterste Zeile abgefragt und anschliessend wird in Zeile 8 die Ampel aufgrund der erledigten Arbeiten (abgehackte Checkboxen) berechnet und angezeigt.
    Sind 100% erledigt dann ist die Ampel grün ansonsten rot.
    Spoiler anzeigen

    Visual Basic-Quellcode

    1. Sub Worksheet_Change(ByVal Target As Excel.Range)
    3. letzteZeile = Cells(Rows.Count, 10).End(xlUp).Row
    5. 'bei einer Änderung in der Spalte "E" wird das Makro Worksheet Activate ausgeführt.
    6. If Not Intersect(Target, Range("E" & ersteZeile & ":E" & letzteZeile)) Is Nothing Then
    7. Application.EnableEvents = False
    10. '*************************************************************************************************
    11. '** 1. FORMATIERUNG SPALTE A
    12. '*************************************************************************************************
    14. ' 1.1 Abfrage der Spalte E -> Funktionen für die Formatierung der Spalte A
    16. For i = ersteZeile To letzteZeile Step 3
    17. For j = 1 To 2 Step 1
    18. If IsEmpty(Cells(i, 5).Value) = True Then
    19. Cells(i, 1).Value = "0"
    20. Else: Cells(i, 1).Value = "1"
    21. End If
    23. i = i + 1
    25. Next j
    26. If j = 2 Then i = i + 3
    28. Next
    30. ' 1.2 Funktion für das Ampelsystem in Spalte A (Kreditoren)
    32. iPend = WorksheetFunction.CountIf(Range("A" & ersteZeile & ":A" & letzteZeile), "0") ' Abfrage Anzahl der pendenten Kreditorenrechnungen
    33. iErl = WorksheetFunction.CountIf(Range("A" & ersteZeile & ":A" & letzteZeile), "1") ' Abfrage Anzahl erledigte Kreditoren
    34. Range("A8").Value = iErl & " / " & iPend + iErl ' Berechnung in % der gesamthaft erledigten Kreditoren -> Ausgabe in Zelle A8
    36. If 100 / (iPend + iErl) * iErl = 100 Then ' wenn 100% erledigt dann...
    37. Range("A7").Interior.Color = RGB(128, 128, 128) ' Färbe Zelle dunkelgrau
    38. Range("A7").Value = "n"
    39. Range("A7").Font.ColorIndex = 4 ' Schriftfarbe grün -> Ampel grün
    40. Else
    41. Range("A7").Value = "n"
    42. Range("A7").Font.ColorIndex = 3 ' Schriftfarbe rot -> Ampel rot
    43. End If
    46. '************************************************************************************************
    47. '** 2. FORMATIERUNG SPALTE B
    48. '************************************************************************************************
    50. ' 2.1 Abfrage der Spalte E -> Funktionen für die Formatierung der Spalte B
    52. For i = (ersteZeile + 2) To letzteZeile Step 3
    53. For j = 1 To 2 Step 1
    54. If IsEmpty(Cells(i, 5).Value) = True Then
    55. Cells(i, 2).Value = "0"
    56. Else: Cells(i, 2).Value = "1"
    57. End If
    59. i = i + 1
    61. Next j
    62. If j = 2 Then i = i + 3
    64. Next
    66. ' 2.2 Funktion für das Ampelsystem in Spalte B (Debitoren)
    68. iPend = WorksheetFunction.CountIf(Range("B" & ersteZeile & ":B" & letzteZeile), "0") ' Abfrage Anzahl der pendenten Kreditorenrechnungen
    69. iErl = WorksheetFunction.CountIf(Range("B" & ersteZeile & ":B" & letzteZeile), "1") ' Abfrage Anzahl erledigte Kreditoren
    70. Range("B8").Value = iErl & " / " & iPend + iErl ' Berechnung in % der gesamthaft erledigten Kreditoren -> Ausgabe in Zelle A8
    72. If 100 / (iPend + iErl) * iErl = 100 Then ' wenn 100% erledigt dann...
    73. Range("B7").Interior.Color = RGB(128, 128, 128) ' Färbe Zelle dunkelgrau
    74. Range("B7").Value = "n"
    75. Range("B7").Font.ColorIndex = 4 ' Schriftfarbe grün -> Ampel grün
    76. Else
    77. Range("B7").Value = "n"
    78. Range("B7").Font.ColorIndex = 3 ' Schriftfarbe rot -> Ampel rot
    79. End If
    81. '************************************************************************************************
    82. '** 3. FORMATIERUNG SPALTE C
    83. '************************************************************************************************
    85. ' 3.1 Abfrage der Spalte E -> Funktionen für die Formatierung der Spalte C
    87. For i = (ersteZeile + 4) To letzteZeile Step 5
    88. If IsEmpty(Cells(i, 5).Value) = True Then
    89. Cells(i, 3).Value = "0"
    90. Else: Cells(i, 3).Value = "1"
    91. End If
    93. Next
    95. ' 5.2 Funktion für das Ampelsystem in Spalte C (Netting)
    97. iPend = WorksheetFunction.CountIf(Range("C" & ersteZeile & ":C" & letzteZeile), "0") ' Abfrage Anzahl der pendenten Kreditorenrechnungen
    98. iErl = WorksheetFunction.CountIf(Range("C" & ersteZeile & ":C" & letzteZeile), "1") ' Abfrage Anzahl erledigte Kreditoren
    99. Range("C8").Value = iErl & " / " & iPend + iErl ' Berechnung in % der gesamthaft erledigten Kreditoren -> Ausgabe in Zelle A8
    101. If 100 / (iPend + iErl) * iErl = 100 Then ' wenn 100% erledigt dann...
    102. Range("C7").Interior.Color = RGB(128, 128, 128) ' Färbe Zelle dunkelgrau
    103. Range("C7").Value = "n"
    104. Range("C7").Font.ColorIndex = 4 ' Schriftfarbe grün -> Ampel grün
    105. Else
    106. Range("C7").Value = "n"
    107. Range("C7").Font.ColorIndex = 3 ' Schriftfarbe rot -> Ampel rot
    108. End If
    110. Application.ScreenUpdating = True
    112. Application.EnableEvents = True
    114. End If
    116. End Sub


    Wie bereits eingangs erwähnt funktioniert es soweit, leider viel zu langsam. Deshalb möchte ich euch fragen, ob man etwas am Code verbessern kann, so dass die Geschwindigkeit massiv erhöht wird.
    Ich bin für jeden Input dankbar.

    Gruss
    Andreas

    CodeTags und Spoiler gesetzt ~VaporiZed

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „VaporiZed“ ()

Facebook