Excel VB UserForm - Change CommandButton BackColor after click in my Userform - change back to standardColor after click again...

P

Pfiffikus

New Member
Joined
Jan 31, 2025
Messages
10
Office Version
  1. 2016
Platform
  1. Windows
Hello, I'm not very good at programming ExcelVB code, but I tried to program a smart solution for a friend's problem anyway.

But I don't know what to do now: the user form has a lot of buttons.
They simulate a vaccination record. When you check vaccination records,
you should always press a status button, but each disease can only have one status.
My idea was that when the button is pressed, background-Color should Change to red-color (status Display) and the value in the Excel table cell provided,
should be increased by 1.
If you have click the wrong button, the value should be reduced by 1 and the button should return to its standard color.
That doesn't work - and when all buttons have been pressed, all colored buttons should be set to the standard Color by a Save Button for the next vaccination record check.
Here is my programming first - if you have any further questions, I could explain more here. Sorry for my bad english - be a german - her the Code I have problems:
VBA Code: 
Option Explicit

'Declaration des Dictionarys
Private buttonStates As Object ' Dictionary für die Button-Zustände

' UserForm Initialisierung
'***************************************
Private Sub UserForm_Initialize()
    ' Dictionary initialisieren
    Set buttonStates = CreateObject("Scripting.Dictionary")
    Dim wsData As Worksheet
    Dim lastRow As Long
    Dim currentTop As Double
    Dim i As Long, j As Integer
    Dim colStart As Integer, colEnd As Integer
    Dim frame As MSForms.frame, button As MSForms.CommandButton

    ' Arbeitsblatt "Data" festlegen
    '--------------------------------
    Set wsData = ThisWorkbook.Sheets("Data")

    ' Scrollbalken einstellen
    '----------------------------
    With Me
        .ScrollBars = fmScrollBarsBoth
        .ScrollHeight = .InsideHeight + 380
        .ScrollWidth = .InsideWidth + 25
    End With

    ' ComboBoxen dynamisch füllen
    '--------------------------------
    FillComboBox Me.cbo_Schuljahr, wsData, "A"
    FillComboBox Me.cbo_Schule, wsData, "B"
    FillComboBox Me.cbo_Klasse, wsData, "C"
    
    ' Label für verbleibende Impfbücher initialisieren
    '-----------------------------------------------------
    Me.lbl_RemainingBooks.Caption = "Rest: " & Me.txtbx_AnzahlImpfbuecher.Value
    Me.lbl_RemainingBooks.Font.Bold = True
    Me.lbl_RemainingBooks.ForeColor = RGB(255, 0, 0) ' Rot
    
End Sub

' Funktion: ComboBox füllen
'***************************************
Private Sub FillComboBox(cbo As MSForms.ComboBox, ws As Worksheet, col As String)
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).row
    cbo.Clear
    cbo.RowSource = ws.name & "!" & col & "2:" & col & lastRow
End Sub

' Button Speichern
'***************************************
Private Sub btn_Speichern_Click()
    Dim wsImpf As Worksheet
    Dim schuljahr As String, schule As String, klasse As String
    Dim anzahlImpfbuecher As String, anzahlSchueler As String
    Dim gesamtImpfbuecher As String, gesamtSchueler As String
    Static remainingBooks As Long ' Zähler für verbleibende Bücher
    
    ' Arbeitsblatt festlegen
    '------------------------------------------------
    Set wsImpf = ThisWorkbook.Sheets("Impfkontrolle")
    
    ' Eingabewerte aus der UserForm auslesen
    '------------------------------------------------
    schuljahr = Me.cbo_Schuljahr.Value
    schule = Me.cbo_Schule.Value
    klasse = Me.cbo_Klasse.Value
    
'    anzahlImpfbuecher = Me.txtbx_AnzahlImpfbuecher.Value
'    anzahlSchueler = Me.txtbx_AnzahlSchueler.Value

    If IsNumeric(Me.txtbx_AnzahlImpfbuecher.Value) Then
        anzahlImpfbuecher = CLng(Me.txtbx_AnzahlImpfbuecher.Value)
    Else
        anzahlImpfbuecher = 0
    End If

    If IsNumeric(Me.txtbx_AnzahlSchueler.Value) Then
        anzahlSchueler = CLng(Me.txtbx_AnzahlSchueler.Value)
    Else
        anzahlSchueler = 0
    End If
    
    If schuljahr = "" Or schule = "" Or klasse = "" Or anzahlImpfbuecher = "" Or anzahlSchueler = "" Then
        MsgBox "Bitte alle Felder ausfüllen!", vbExclamation
        Exit Sub
    End If

    ' Werte in die Tabelle schreiben
    '------------------------------------
    With wsImpf
        .Cells(3, 2).Value = schuljahr
        .Cells(4, 2).Value = schule
        .Cells(5, 2).Value = klasse
        .Cells(6, 2).Value = anzahlImpfbuecher
        .Cells(7, 2).Value = anzahlSchueler
        
        ' Gesamtsummen aktualisieren
        '---------------------------------
        .Cells(6, 5).Value = .Cells(6, 5).Value + anzahlImpfbuecher
        .Cells(7, 5).Value = .Cells(7, 5).Value + anzahlSchueler
    End With
            
        ' Textfelder leeren und Label zurücksetzen
        '-------------------------------------------
        Me.txtbx_AnzahlImpfbuecher.Value = ""
        Me.txtbx_AnzahlSchueler.Value = ""
        Me.lbl_RemainingBooks.Caption = "Rest: 0"
    
    ' Initialisierung des Zählers beim ersten Speichern
    '----------------------------------------------------
    If remainingBooks = 0 Then
        remainingBooks = CLng(anzahlImpfbuecher)
    End If

    ' Zähler reduzieren
    '----------------------
    If remainingBooks > 0 Then
        remainingBooks = remainingBooks - 1
        Me.lbl_RemainingBooks.Caption = "Rest: " & remainingBooks
    End If
    
    ' Erfolgsnachricht
    MsgBox "Daten erfolgreich gespeichert und Gesamtsummen aktualisiert!", vbInformation
    
    ' Wenn alle Bücher kontrolliert sind
    '------------------------------------
    If remainingBooks = 0 Then
        MsgBox "Bitte nächste Klasse auswählen!", vbInformation
    ' Optional: Weitere Logik, z. B. Fortschritt zurücksetzen oder speichern
    End If
End Sub

' Funktion: Zelle inkrementieren
'******************************************
Private Sub IncrementCell(sheetName As String, targetRow As Long, targetColumn As Long, incrementValue As Long)
    Dim ws As Worksheet
    Dim currentValue As Variant

    ' Ziel-Sheet setzen
    Set ws = ThisWorkbook.Sheets(sheetName)

    ' Aktuellen Wert auslesen und inkrementieren
    currentValue = ws.Cells(targetRow, targetColumn).Value

    If IsNumeric(currentValue) Then
        ws.Cells(targetRow, targetColumn).Value = currentValue + incrementValue
    Else
        ws.Cells(targetRow, targetColumn).Value = incrementValue
    End If

End Sub

' Generische Klick-Funktion für Buttons
'*****************************************
Private Sub GenericButtonClick()
    Dim btn As MSForms.CommandButton
    Dim sheetName As String
    Dim targetRow As Long
    Dim targetColumn As Long
    Dim parts() As String
    'Dim buttonKey As String
    Dim ws As Worksheet
    Dim currentValue As Long

    ' Ziel-Sheet festlegen
    sheetName = "Impfkontrolle"
    Set ws = ThisWorkbook.Sheets(sheetName)

    ' Prüfen, ob ActiveControl ein Button ist
    If TypeOf Me.ActiveControl Is MSForms.CommandButton Then
        Set btn = Me.ActiveControl
        'buttonKey = btn.name ' Eindeutiger Schlüssel für den Button
    Else
        MsgBox "Das aktive Steuerelement ist kein Button!", vbExclamation
        Exit Sub
    End If

    ' Button-Name analysieren (z. B. Btn_Tetanus_1)
    parts = Split(btn.name, "_")

    ' Ziel-Reihe und -Spalte bestimmen
    If UBound(parts) = 2 Then
        If InStr(parts(1), "Impftiter") > 0 Then
        ' Impftiter-Logik(Masern-, Mumps-, Röteln-Impftiter)
        Select Case parts(1)
            Case "MasernImpftiter": targetRow = 28
            Case "MumpsImpftiter": targetRow = 29
            Case "RoetelnImpftiter": targetRow = 30
            Case Else
                MsgBox "Unbekannter Impftiter: " & parts(1), vbExclamation
                Exit Sub
        End Select
        
        ' Zielspalte festlegen: Spalte B = 2 oder Spalte E = 5 (abhängig von der letzten Ziffer)
        '----------------------------------------------------------------------------------------
        Select Case CInt(parts(2))
            Case 1
                targetColumn = 2 ' Spalte B
            Case 2
                targetColumn = 5 ' Spalte E
            Case Else
                MsgBox "Ungültige Spalte für Impftiter: " & btn.name, vbExclamation
                Exit Sub
        End Select
    Else
        ' Impfart (z. B. Tetanus) und Zielspalte bestimmen
        Select Case parts(1)
            Case "Tetanus": targetRow = 13
            Case "Diphterie": targetRow = 14
            Case "Pertussis": targetRow = 15
            Case "Polio": targetRow = 16
            Case "HepatitisB": targetRow = 17
            Case "Masern": targetRow = 18
            Case "Mumps": targetRow = 19
            Case "Roeteln": targetRow = 20
            Case "Varizellen": targetRow = 21
            Case "Meningokokken": targetRow = 22
            Case "FSME": targetRow = 23
            Case "HPV": targetRow = 24
            Case Else
                MsgBox "Unbekannte Impfart: " & parts(1), vbExclamation
                Exit Sub
        End Select
    End If

    ' Zielspalte festlegen (B oder E)
    If IsNumeric(parts(2)) Then
        targetColumn = CInt(parts(2)) + 1 ' Spalte B = 2
    Else
        MsgBox "Ungültige Spalte im Button-Namen: " & btn.name, vbExclamation
        Exit Sub
    End If

    ' Aktuellen Wert abrufen
    currentValue = ws.Cells(targetRow, targetColumn).Value
    If Not IsNumeric(currentValue) Then currentValue = 0
        'Logik: Wert erhöhen/reduzieren und Farbe wechseln
        If btn.BackColor = RGB(255, 0, 0) Then
            ' Wenn rot, zurücksetzen
            btn.BackColor = RGB(240, 240, 240) ' Standardfarbe
            ws.Cells(targetRow, targetColumn).Value = currentValue - 1 ' Wert um 1 reduzieren
        Else
            ' Wenn Standardfarbe, erhöhen und rot färben
            btn.BackColor = RGB(255, 0, 0) ' Rot markieren
            ws.Cells(targetRow, targetColumn).Value = currentValue + 1 ' Wert um 1 erhöhen
        End If
    Else
        MsgBox "Ungültiger Button-Name: " & btn.name, vbExclamation
        Exit Sub
    End If
End Sub

' Funktion: Daten exportieren
Private Sub ExportDataToFile()
    Dim ws As Worksheet
    Dim exportFileName As String

    ' Zielarbeitsblatt setzen
    Set ws = ThisWorkbook.Sheets("Impfkontrolle")

    ' Dateiname erstellen
    exportFileName = ThisWorkbook.Path & "\Impfkontrolle_" & Format(Now, "yyyymmdd_HHMMSS") & ".xlsx"
    
    ' Exportieren
    ws.Copy
    ActiveWorkbook.SaveAs Filename:=exportFileName, FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close SaveChanges:=False
    MsgBox "Daten exportiert nach: " & exportFileName, vbInformation
End Sub

' Buttons der Form
'***************************************
Private Sub btn_Tetanus_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Tetanus_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Tetanus_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Tetanus_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Tetanus_3_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Tetanus_3.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Tetanus_4_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Tetanus_4.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Tetanus_5_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Tetanus_5.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_Diphterie_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Diphterie_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Diphterie_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Diphterie_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Diphterie_3_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Diphterie_3.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Diphterie_4_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Diphterie_4.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Diphterie_5_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Diphterie_5.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_Pertussis_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Pertussis_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Pertussis_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Pertussis_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Pertussis_3_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Pertussis_3.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Pertussis_4_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Pertussis_4.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Pertussis_5_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Pertussis_5.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_Polio_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Polio_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Polio_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Polio_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Polio_3_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Polio_3.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Polio_4_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Polio_4.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Polio_5_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Polio_5.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_HepatitisB_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_HepatitisB_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_HepatitisB_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_HepatitisB_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_HepatitisB_3_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_HepatitisB_3.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_HepatitisB_4_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_HepatitisB_4.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_Masern_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Masern_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Masern_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Masern_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Masern_3_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Masern_3.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Masern_4_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Masern_4.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_Mumps_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Mumps_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Mumps_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Mumps_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Mumps_3_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Mumps_3.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Mumps_4_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Mumps_4.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_Roeteln_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Roeteln_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Roeteln_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Roeteln_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Roeteln_3_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Roeteln_3.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Roeteln_4_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Roeteln_4.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_Varizellen_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Varizellen_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Varizellen_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Varizellen_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Varizellen_3_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Varizellen_3.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Varizellen_4_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Varizellen_4.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_Meningokokken_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Meningokokken_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Meningokokken_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Meningokokken_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Meningokokken_3_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Meningokokken_3.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_Meningokokken_4_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_Meningokokken_4.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_FSME_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_FSME_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_FSME_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_FSME_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_FSME_3_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_FSME_3.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_FSME_4_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_FSME_4.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_FSME_5_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_FSME_5.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_HPV_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_HPV_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_HPV_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_HPV_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_HPV_3_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_HPV_3.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_HPV_4_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_HPV_4.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_MasernImpftiter_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_MasernImpftiter_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_MasernImpftiter_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_MasernImpftiter_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_MumpsImpftiter_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_MumpsImpftiter_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_MumpsImpftiter_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_MumpsImpftiter_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

'---------------------------------------
Private Sub btn_RoetelnImpftiter_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_RoetelnImpftiter_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Private Sub btn_RoetelnImpftiter_2_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
    btn_RoetelnImpftiter_2.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
1738341734234.png
 
Upvote 0
Hi and welcome to MrExcel


Is this what you need?
Set these 2 codes and test.

I highlighted the change made in blue
Rich (BB code): 
Private Sub btn_Tetanus_1_Click()
    Call GenericButtonClick
    ' Aktion des Buttons
'    btn_Tetanus_1.BackColor = RGB(255, 0, 0) ' Rot markieren
End Sub

Rich (BB code): 
Private Sub GenericButtonClick()
    Dim btn As MSForms.CommandButton
    Dim sheetName As String
    Dim targetRow As Long
    Dim targetColumn As Long
    Dim parts() As String
    'Dim buttonKey As String
    Dim ws As Worksheet
    Dim currentValue As Long

    ' Ziel-Sheet festlegen
    sheetName = "Impfkontrolle"
    Set ws = ThisWorkbook.Sheets(sheetName)

    ' Prüfen, ob ActiveControl ein Button ist
    If TypeOf Me.ActiveControl Is MSForms.CommandButton Then
        Set btn = Me.ActiveControl
        'buttonKey = btn.name ' Eindeutiger Schlüssel für den Button
    Else
        MsgBox "Das aktive Steuerelement ist kein Button!", vbExclamation
        Exit Sub
    End If

    ' Button-Name analysieren (z. B. Btn_Tetanus_1)
    parts = Split(btn.Name, "_")

    ' Ziel-Reihe und -Spalte bestimmen
    If UBound(parts) = 2 Then
        If InStr(parts(1), "Impftiter") > 0 Then
        ' Impftiter-Logik(Masern-, Mumps-, Röteln-Impftiter)
        Select Case parts(1)
            Case "MasernImpftiter": targetRow = 28
            Case "MumpsImpftiter": targetRow = 29
            Case "RoetelnImpftiter": targetRow = 30
            Case Else
                MsgBox "Unbekannter Impftiter: " & parts(1), vbExclamation
                Exit Sub
        End Select
       
        ' Zielspalte festlegen: Spalte B = 2 oder Spalte E = 5 (abhängig von der letzten Ziffer)
        '----------------------------------------------------------------------------------------
        Select Case CInt(parts(2))
            Case 1
                targetColumn = 2 ' Spalte B
            Case 2
                targetColumn = 5 ' Spalte E
            Case Else
                MsgBox "Ungültige Spalte für Impftiter: " & btn.Name, vbExclamation
                Exit Sub
        End Select
    Else
        ' Impfart (z. B. Tetanus) und Zielspalte bestimmen
        Select Case parts(1)
            Case "Tetanus": targetRow = 13
            Case "Diphterie": targetRow = 14
            Case "Pertussis": targetRow = 15
            Case "Polio": targetRow = 16
            Case "HepatitisB": targetRow = 17
            Case "Masern": targetRow = 18
            Case "Mumps": targetRow = 19
            Case "Roeteln": targetRow = 20
            Case "Varizellen": targetRow = 21
            Case "Meningokokken": targetRow = 22
            Case "FSME": targetRow = 23
            Case "HPV": targetRow = 24
            Case Else
                MsgBox "Unbekannte Impfart: " & parts(1), vbExclamation
                Exit Sub
        End Select
    End If

    ' Zielspalte festlegen (B oder E)
    If IsNumeric(parts(2)) Then
        targetColumn = CInt(parts(2)) + 1 ' Spalte B = 2
    Else
        MsgBox "Ungültige Spalte im Button-Namen: " & btn.Name, vbExclamation
        Exit Sub
    End If

    ' Aktuellen Wert abrufen
    currentValue = ws.Cells(targetRow, targetColumn).Value
    If Not IsNumeric(currentValue) Then currentValue = 0
        'Logik: Wert erhöhen/reduzieren und Farbe wechseln
        If btn.BackColor = RGB(255, 0, 0) Then
            ' Wenn rot, zurücksetzen
            btn.BackColor = RGB(240, 240, 240) ' Standardfarbe
            ws.Cells(targetRow, targetColumn).Value = 0 'currentValue - 1 ' Wert um 1 reduzieren
        Else
            ' Wenn Standardfarbe, erhöhen und rot färben
            btn.BackColor = RGB(255, 0, 0) ' Rot markieren
            ws.Cells(targetRow, targetColumn).Value = 1 'currentValue + 1 ' Wert um 1 erhöhen
        End If
    Else
        MsgBox "Ungültiger Button-Name: " & btn.Name, vbExclamation
        Exit Sub
    End If
End Sub
 
Upvote 0
Pfiffikus said:
can i make the code lean?
Click to expand...
I didn't understand well.

Do you want to simplify or reduce the code?
I can put all the commandbutton in a class.

Add this in a Module Class. Name Module Clase to Class1
Rich (BB code): 
Option Explicit

Public WithEvents MultCommand As MSForms.CommandButton

Private Sub MultCommand_Click()
  Call UserForm1.GenericButtonClick     'fit name of your userform
End Sub

Replace all your userform code for this:
VBA Code: 
Option Explicit

'Declaration des Dictionarys
Private buttonStates As Object ' Dictionary für die Button-Zustände
Dim CommBtn() As New Class1         'At the start of all code

Private Sub CommandButton1_Click()

End Sub

' UserForm Initialisierung
'***************************************
Private Sub UserForm_Initialize()
    ' Dictionary initialisierenPrivate Sub UserForm_Initialize()

    Set buttonStates = CreateObject("Scripting.Dictionary")
    Dim wsData As Worksheet
    Dim lastRow As Long
    Dim currentTop As Double
    Dim i As Long, j As Integer
    Dim colStart As Integer, colEnd As Integer
    Dim frame As MSForms.frame, button As MSForms.CommandButton


    ' Arbeitsblatt "Data" festlegen
    '--------------------------------
    Set wsData = ThisWorkbook.Sheets("Data")

    ' Scrollbalken einstellen
    '----------------------------
    With Me
        .ScrollBars = fmScrollBarsBoth
        .ScrollHeight = .InsideHeight + 380
        .ScrollWidth = .InsideWidth + 25
    End With

    ' ComboBoxen dynamisch füllen
    '--------------------------------
    FillComboBox Me.cbo_Schuljahr, wsData, "A"
    FillComboBox Me.cbo_Schule, wsData, "B"
    FillComboBox Me.cbo_Klasse, wsData, "C"
    
    ' Label für verbleibende Impfbücher initialisieren
    '-----------------------------------------------------
    Me.lbl_RemainingBooks.Caption = "Rest: " & Me.txtbx_AnzahlImpfbuecher.Value
    Me.lbl_RemainingBooks.Font.Bold = True
    Me.lbl_RemainingBooks.ForeColor = RGB(255, 0, 0) ' Rot
  
  Dim ctrl As MSForms.Control
  Dim tot As Long
  For Each ctrl In Me.Controls
    If TypeName(ctrl) = "CommandButton" Then
      'Load only button names that have "_" in the second to last position
      If Mid(ctrl.Name, Len(ctrl.Name) - 1, 1) = "_" Then
        tot = tot + 1
        ReDim Preserve CommBtn(tot)
        Set CommBtn(tot).MultCommand = ctrl
      End If
    End If
  Next

End Sub

' Funktion: ComboBox füllen
'***************************************
Private Sub FillComboBox(cbo As MSForms.ComboBox, ws As Worksheet, col As String)
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
    cbo.Clear
    cbo.RowSource = ws.Name & "!" & col & "2:" & col & lastRow
End Sub

' Button Speichern
'***************************************
Private Sub btn_Speichern_Click()
    Dim wsImpf As Worksheet
    Dim schuljahr As String, schule As String, klasse As String
    Dim anzahlImpfbuecher As String, anzahlSchueler As String
    Dim gesamtImpfbuecher As String, gesamtSchueler As String
    Static remainingBooks As Long ' Zähler für verbleibende Bücher
    
    ' Arbeitsblatt festlegen
    '------------------------------------------------
    Set wsImpf = ThisWorkbook.Sheets("Impfkontrolle")
    
    ' Eingabewerte aus der UserForm auslesen
    '------------------------------------------------
    schuljahr = Me.cbo_Schuljahr.Value
    schule = Me.cbo_Schule.Value
    klasse = Me.cbo_Klasse.Value
    
'    anzahlImpfbuecher = Me.txtbx_AnzahlImpfbuecher.Value
'    anzahlSchueler = Me.txtbx_AnzahlSchueler.Value

    If IsNumeric(Me.txtbx_AnzahlImpfbuecher.Value) Then
        anzahlImpfbuecher = CLng(Me.txtbx_AnzahlImpfbuecher.Value)
    Else
        anzahlImpfbuecher = 0
    End If

    If IsNumeric(Me.txtbx_AnzahlSchueler.Value) Then
        anzahlSchueler = CLng(Me.txtbx_AnzahlSchueler.Value)
    Else
        anzahlSchueler = 0
    End If
    
    If schuljahr = "" Or schule = "" Or klasse = "" Or anzahlImpfbuecher = "" Or anzahlSchueler = "" Then
        MsgBox "Bitte alle Felder ausfüllen!", vbExclamation
        Exit Sub
    End If

    ' Werte in die Tabelle schreiben
    '------------------------------------
    With wsImpf
        .Cells(3, 2).Value = schuljahr
        .Cells(4, 2).Value = schule
        .Cells(5, 2).Value = klasse
        .Cells(6, 2).Value = anzahlImpfbuecher
        .Cells(7, 2).Value = anzahlSchueler
        
        ' Gesamtsummen aktualisieren
        '---------------------------------
        .Cells(6, 5).Value = .Cells(6, 5).Value + anzahlImpfbuecher
        .Cells(7, 5).Value = .Cells(7, 5).Value + anzahlSchueler
    End With
            
        ' Textfelder leeren und Label zurücksetzen
        '-------------------------------------------
        Me.txtbx_AnzahlImpfbuecher.Value = ""
        Me.txtbx_AnzahlSchueler.Value = ""
        Me.lbl_RemainingBooks.Caption = "Rest: 0"
    
    ' Initialisierung des Zählers beim ersten Speichern
    '----------------------------------------------------
    If remainingBooks = 0 Then
        remainingBooks = CLng(anzahlImpfbuecher)
    End If

    ' Zähler reduzieren
    '----------------------
    If remainingBooks > 0 Then
        remainingBooks = remainingBooks - 1
        Me.lbl_RemainingBooks.Caption = "Rest: " & remainingBooks
    End If
    
    ' Erfolgsnachricht
    MsgBox "Daten erfolgreich gespeichert und Gesamtsummen aktualisiert!", vbInformation
    
    ' Wenn alle Bücher kontrolliert sind
    '------------------------------------
    If remainingBooks = 0 Then
        MsgBox "Bitte nächste Klasse auswählen!", vbInformation
    ' Optional: Weitere Logik, z. B. Fortschritt zurücksetzen oder speichern
    End If
End Sub

' Funktion: Zelle inkrementieren
'******************************************
Private Sub IncrementCell(sheetName As String, targetRow As Long, targetColumn As Long, incrementValue As Long)
    Dim ws As Worksheet
    Dim currentValue As Variant

    ' Ziel-Sheet setzen
    Set ws = ThisWorkbook.Sheets(sheetName)

    ' Aktuellen Wert auslesen und inkrementieren
    currentValue = ws.Cells(targetRow, targetColumn).Value

    If IsNumeric(currentValue) Then
        ws.Cells(targetRow, targetColumn).Value = currentValue + incrementValue
    Else
        ws.Cells(targetRow, targetColumn).Value = incrementValue
    End If

End Sub

' Generische Klick-Funktion für Buttons
'*****************************************
Public Sub GenericButtonClick()
    Dim btn As MSForms.CommandButton
    Dim sheetName As String
    Dim targetRow As Long
    Dim targetColumn As Long
    Dim parts() As String
    'Dim buttonKey As String
    Dim ws As Worksheet
    Dim currentValue As Long

    ' Ziel-Sheet festlegen
    sheetName = "Impfkontrolle"
    Set ws = ThisWorkbook.Sheets(sheetName)

    ' Prüfen, ob ActiveControl ein Button ist
    If TypeOf Me.ActiveControl Is MSForms.CommandButton Then
        Set btn = Me.ActiveControl
        'buttonKey = btn.name ' Eindeutiger Schlüssel für den Button
    Else
        MsgBox "Das aktive Steuerelement ist kein Button!", vbExclamation
        Exit Sub
    End If

    ' Button-Name analysieren (z. B. Btn_Tetanus_1)
    parts = Split(btn.Name, "_")

    ' Ziel-Reihe und -Spalte bestimmen
    If UBound(parts) = 2 Then
        If InStr(parts(1), "Impftiter") > 0 Then
        ' Impftiter-Logik(Masern-, Mumps-, Röteln-Impftiter)
        Select Case parts(1)
            Case "MasernImpftiter": targetRow = 28
            Case "MumpsImpftiter": targetRow = 29
            Case "RoetelnImpftiter": targetRow = 30
            Case Else
                MsgBox "Unbekannter Impftiter: " & parts(1), vbExclamation
                Exit Sub
        End Select
        
        ' Zielspalte festlegen: Spalte B = 2 oder Spalte E = 5 (abhängig von der letzten Ziffer)
        '----------------------------------------------------------------------------------------
        Select Case CInt(parts(2))
            Case 1
                targetColumn = 2 ' Spalte B
            Case 2
                targetColumn = 5 ' Spalte E
            Case Else
                MsgBox "Ungültige Spalte für Impftiter: " & btn.Name, vbExclamation
                Exit Sub
        End Select
    Else
        ' Impfart (z. B. Tetanus) und Zielspalte bestimmen
        Select Case parts(1)
            Case "Tetanus": targetRow = 13
            Case "Diphterie": targetRow = 14
            Case "Pertussis": targetRow = 15
            Case "Polio": targetRow = 16
            Case "HepatitisB": targetRow = 17
            Case "Masern": targetRow = 18
            Case "Mumps": targetRow = 19
            Case "Roeteln": targetRow = 20
            Case "Varizellen": targetRow = 21
            Case "Meningokokken": targetRow = 22
            Case "FSME": targetRow = 23
            Case "HPV": targetRow = 24
            Case Else
                MsgBox "Unbekannte Impfart: " & parts(1), vbExclamation
                Exit Sub
        End Select
    End If

    ' Zielspalte festlegen (B oder E)
    If IsNumeric(parts(2)) Then
        targetColumn = CInt(parts(2)) + 1 ' Spalte B = 2
    Else
        MsgBox "Ungültige Spalte im Button-Namen: " & btn.Name, vbExclamation
        Exit Sub
    End If

    ' Aktuellen Wert abrufen
    currentValue = ws.Cells(targetRow, targetColumn).Value
    If Not IsNumeric(currentValue) Then currentValue = 0
        'Logik: Wert erhöhen/reduzieren und Farbe wechseln
        If btn.BackColor = RGB(255, 0, 0) Then
            ' Wenn rot, zurücksetzen
            btn.BackColor = RGB(240, 240, 240) ' Standardfarbe
            ws.Cells(targetRow, targetColumn).Value = 0 'currentValue - 1 ' Wert um 1 reduzieren
        Else
            ' Wenn Standardfarbe, erhöhen und rot färben
            btn.BackColor = RGB(255, 0, 0) ' Rot markieren
            ws.Cells(targetRow, targetColumn).Value = 1 'currentValue + 1 ' Wert um 1 erhöhen
        End If
    Else
        MsgBox "Ungültiger Button-Name: " & btn.Name, vbExclamation
        Exit Sub
    End If
End Sub

' Funktion: Daten exportieren
Private Sub ExportDataToFile()
    Dim ws As Worksheet
    Dim exportFileName As String

    ' Zielarbeitsblatt setzen
    Set ws = ThisWorkbook.Sheets("Impfkontrolle")

    ' Dateiname erstellen
    exportFileName = ThisWorkbook.Path & "\Impfkontrolle_" & Format(Now, "yyyymmdd_HHMMSS") & ".xlsx"
    
    ' Exportieren
    ws.Copy
    ActiveWorkbook.SaveAs Filename:=exportFileName, FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close SaveChanges:=False
    MsgBox "Daten exportiert nach: " & exportFileName, vbInformation
End Sub

Test and comments

😇
 
Upvote 0
DanteAmor said:
I didn't understand well.

Do you want to simplify or reduce the code?
I can put all the commandbutton in a class.

Add this in a Module Class. Name Module Clase to Class1
Rich (BB code): 
Option Explicit

Public WithEvents MultCommand As MSForms.CommandButton

Private Sub MultCommand_Click()
  Call UserForm1.GenericButtonClick     'fit name of your userform
End Sub

Replace all your userform code for this:
VBA Code: 
Option Explicit

'Declaration des Dictionarys
Private buttonStates As Object ' Dictionary für die Button-Zustände
Dim CommBtn() As New Class1         'At the start of all code

Private Sub CommandButton1_Click()

End Sub

' UserForm Initialisierung
'***************************************
Private Sub UserForm_Initialize()
    ' Dictionary initialisierenPrivate Sub UserForm_Initialize()

    Set buttonStates = CreateObject("Scripting.Dictionary")
    Dim wsData As Worksheet
    Dim lastRow As Long
    Dim currentTop As Double
    Dim i As Long, j As Integer
    Dim colStart As Integer, colEnd As Integer
    Dim frame As MSForms.frame, button As MSForms.CommandButton


    ' Arbeitsblatt "Data" festlegen
    '--------------------------------
    Set wsData = ThisWorkbook.Sheets("Data")

    ' Scrollbalken einstellen
    '----------------------------
    With Me
        .ScrollBars = fmScrollBarsBoth
        .ScrollHeight = .InsideHeight + 380
        .ScrollWidth = .InsideWidth + 25
    End With

    ' ComboBoxen dynamisch füllen
    '--------------------------------
    FillComboBox Me.cbo_Schuljahr, wsData, "A"
    FillComboBox Me.cbo_Schule, wsData, "B"
    FillComboBox Me.cbo_Klasse, wsData, "C"
   
    ' Label für verbleibende Impfbücher initialisieren
    '-----------------------------------------------------
    Me.lbl_RemainingBooks.Caption = "Rest: " & Me.txtbx_AnzahlImpfbuecher.Value
    Me.lbl_RemainingBooks.Font.Bold = True
    Me.lbl_RemainingBooks.ForeColor = RGB(255, 0, 0) ' Rot
 
  Dim ctrl As MSForms.Control
  Dim tot As Long
  For Each ctrl In Me.Controls
    If TypeName(ctrl) = "CommandButton" Then
      'Load only button names that have "_" in the second to last position
      If Mid(ctrl.Name, Len(ctrl.Name) - 1, 1) = "_" Then
        tot = tot + 1
        ReDim Preserve CommBtn(tot)
        Set CommBtn(tot).MultCommand = ctrl
      End If
    End If
  Next

End Sub

' Funktion: ComboBox füllen
'***************************************
Private Sub FillComboBox(cbo As MSForms.ComboBox, ws As Worksheet, col As String)
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
    cbo.Clear
    cbo.RowSource = ws.Name & "!" & col & "2:" & col & lastRow
End Sub

' Button Speichern
'***************************************
Private Sub btn_Speichern_Click()
    Dim wsImpf As Worksheet
    Dim schuljahr As String, schule As String, klasse As String
    Dim anzahlImpfbuecher As String, anzahlSchueler As String
    Dim gesamtImpfbuecher As String, gesamtSchueler As String
    Static remainingBooks As Long ' Zähler für verbleibende Bücher
   
    ' Arbeitsblatt festlegen
    '------------------------------------------------
    Set wsImpf = ThisWorkbook.Sheets("Impfkontrolle")
   
    ' Eingabewerte aus der UserForm auslesen
    '------------------------------------------------
    schuljahr = Me.cbo_Schuljahr.Value
    schule = Me.cbo_Schule.Value
    klasse = Me.cbo_Klasse.Value
   
'    anzahlImpfbuecher = Me.txtbx_AnzahlImpfbuecher.Value
'    anzahlSchueler = Me.txtbx_AnzahlSchueler.Value

    If IsNumeric(Me.txtbx_AnzahlImpfbuecher.Value) Then
        anzahlImpfbuecher = CLng(Me.txtbx_AnzahlImpfbuecher.Value)
    Else
        anzahlImpfbuecher = 0
    End If

    If IsNumeric(Me.txtbx_AnzahlSchueler.Value) Then
        anzahlSchueler = CLng(Me.txtbx_AnzahlSchueler.Value)
    Else
        anzahlSchueler = 0
    End If
   
    If schuljahr = "" Or schule = "" Or klasse = "" Or anzahlImpfbuecher = "" Or anzahlSchueler = "" Then
        MsgBox "Bitte alle Felder ausfüllen!", vbExclamation
        Exit Sub
    End If

    ' Werte in die Tabelle schreiben
    '------------------------------------
    With wsImpf
        .Cells(3, 2).Value = schuljahr
        .Cells(4, 2).Value = schule
        .Cells(5, 2).Value = klasse
        .Cells(6, 2).Value = anzahlImpfbuecher
        .Cells(7, 2).Value = anzahlSchueler
       
        ' Gesamtsummen aktualisieren
        '---------------------------------
        .Cells(6, 5).Value = .Cells(6, 5).Value + anzahlImpfbuecher
        .Cells(7, 5).Value = .Cells(7, 5).Value + anzahlSchueler
    End With
           
        ' Textfelder leeren und Label zurücksetzen
        '-------------------------------------------
        Me.txtbx_AnzahlImpfbuecher.Value = ""
        Me.txtbx_AnzahlSchueler.Value = ""
        Me.lbl_RemainingBooks.Caption = "Rest: 0"
   
    ' Initialisierung des Zählers beim ersten Speichern
    '----------------------------------------------------
    If remainingBooks = 0 Then
        remainingBooks = CLng(anzahlImpfbuecher)
    End If

    ' Zähler reduzieren
    '----------------------
    If remainingBooks > 0 Then
        remainingBooks = remainingBooks - 1
        Me.lbl_RemainingBooks.Caption = "Rest: " & remainingBooks
    End If
   
    ' Erfolgsnachricht
    MsgBox "Daten erfolgreich gespeichert und Gesamtsummen aktualisiert!", vbInformation
   
    ' Wenn alle Bücher kontrolliert sind
    '------------------------------------
    If remainingBooks = 0 Then
        MsgBox "Bitte nächste Klasse auswählen!", vbInformation
    ' Optional: Weitere Logik, z. B. Fortschritt zurücksetzen oder speichern
    End If
End Sub

' Funktion: Zelle inkrementieren
'******************************************
Private Sub IncrementCell(sheetName As String, targetRow As Long, targetColumn As Long, incrementValue As Long)
    Dim ws As Worksheet
    Dim currentValue As Variant

    ' Ziel-Sheet setzen
    Set ws = ThisWorkbook.Sheets(sheetName)

    ' Aktuellen Wert auslesen und inkrementieren
    currentValue = ws.Cells(targetRow, targetColumn).Value

    If IsNumeric(currentValue) Then
        ws.Cells(targetRow, targetColumn).Value = currentValue + incrementValue
    Else
        ws.Cells(targetRow, targetColumn).Value = incrementValue
    End If

End Sub

' Generische Klick-Funktion für Buttons
'*****************************************
Public Sub GenericButtonClick()
    Dim btn As MSForms.CommandButton
    Dim sheetName As String
    Dim targetRow As Long
    Dim targetColumn As Long
    Dim parts() As String
    'Dim buttonKey As String
    Dim ws As Worksheet
    Dim currentValue As Long

    ' Ziel-Sheet festlegen
    sheetName = "Impfkontrolle"
    Set ws = ThisWorkbook.Sheets(sheetName)

    ' Prüfen, ob ActiveControl ein Button ist
    If TypeOf Me.ActiveControl Is MSForms.CommandButton Then
        Set btn = Me.ActiveControl
        'buttonKey = btn.name ' Eindeutiger Schlüssel für den Button
    Else
        MsgBox "Das aktive Steuerelement ist kein Button!", vbExclamation
        Exit Sub
    End If

    ' Button-Name analysieren (z. B. Btn_Tetanus_1)
    parts = Split(btn.Name, "_")

    ' Ziel-Reihe und -Spalte bestimmen
    If UBound(parts) = 2 Then
        If InStr(parts(1), "Impftiter") > 0 Then
        ' Impftiter-Logik(Masern-, Mumps-, Röteln-Impftiter)
        Select Case parts(1)
            Case "MasernImpftiter": targetRow = 28
            Case "MumpsImpftiter": targetRow = 29
            Case "RoetelnImpftiter": targetRow = 30
            Case Else
                MsgBox "Unbekannter Impftiter: " & parts(1), vbExclamation
                Exit Sub
        End Select
       
        ' Zielspalte festlegen: Spalte B = 2 oder Spalte E = 5 (abhängig von der letzten Ziffer)
        '----------------------------------------------------------------------------------------
        Select Case CInt(parts(2))
            Case 1
                targetColumn = 2 ' Spalte B
            Case 2
                targetColumn = 5 ' Spalte E
            Case Else
                MsgBox "Ungültige Spalte für Impftiter: " & btn.Name, vbExclamation
                Exit Sub
        End Select
    Else
        ' Impfart (z. B. Tetanus) und Zielspalte bestimmen
        Select Case parts(1)
            Case "Tetanus": targetRow = 13
            Case "Diphterie": targetRow = 14
            Case "Pertussis": targetRow = 15
            Case "Polio": targetRow = 16
            Case "HepatitisB": targetRow = 17
            Case "Masern": targetRow = 18
            Case "Mumps": targetRow = 19
            Case "Roeteln": targetRow = 20
            Case "Varizellen": targetRow = 21
            Case "Meningokokken": targetRow = 22
            Case "FSME": targetRow = 23
            Case "HPV": targetRow = 24
            Case Else
                MsgBox "Unbekannte Impfart: " & parts(1), vbExclamation
                Exit Sub
        End Select
    End If

    ' Zielspalte festlegen (B oder E)
    If IsNumeric(parts(2)) Then
        targetColumn = CInt(parts(2)) + 1 ' Spalte B = 2
    Else
        MsgBox "Ungültige Spalte im Button-Namen: " & btn.Name, vbExclamation
        Exit Sub
    End If

    ' Aktuellen Wert abrufen
    currentValue = ws.Cells(targetRow, targetColumn).Value
    If Not IsNumeric(currentValue) Then currentValue = 0
        'Logik: Wert erhöhen/reduzieren und Farbe wechseln
        If btn.BackColor = RGB(255, 0, 0) Then
            ' Wenn rot, zurücksetzen
            btn.BackColor = RGB(240, 240, 240) ' Standardfarbe
            ws.Cells(targetRow, targetColumn).Value = 0 'currentValue - 1 ' Wert um 1 reduzieren
        Else
            ' Wenn Standardfarbe, erhöhen und rot färben
            btn.BackColor = RGB(255, 0, 0) ' Rot markieren
            ws.Cells(targetRow, targetColumn).Value = 1 'currentValue + 1 ' Wert um 1 erhöhen
        End If
    Else
        MsgBox "Ungültiger Button-Name: " & btn.Name, vbExclamation
        Exit Sub
    End If
End Sub

' Funktion: Daten exportieren
Private Sub ExportDataToFile()
    Dim ws As Worksheet
    Dim exportFileName As String

    ' Zielarbeitsblatt setzen
    Set ws = ThisWorkbook.Sheets("Impfkontrolle")

    ' Dateiname erstellen
    exportFileName = ThisWorkbook.Path & "\Impfkontrolle_" & Format(Now, "yyyymmdd_HHMMSS") & ".xlsx"
   
    ' Exportieren
    ws.Copy
    ActiveWorkbook.SaveAs Filename:=exportFileName, FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close SaveChanges:=False
    MsgBox "Daten exportiert nach: " & exportFileName, vbInformation
End Sub

Test and comments

😇
Click to expand...


Sir I thought reduce the Code - before I will comment - I m a beginner, I will write the whole Code to learn better (not Copy&Paste) - then will test and then I will comment :-) thank for your help i m so lucky :cool:
 
Upvote 0
With the class, I'm removing all the lines you have for each commandbutton.
Every time you click on a button, the class will be executed. So in a single event you have all 28 events.

----------------
About Class Module:
learn.microsoft.com

Program with class modules

Office VBA reference topic
learn.microsoft.com

excelmacromastery.com

VBA Class Modules - The Ultimate Guide - Excel Macro Mastery

A VBA Class module is used to create your own custom objects in VBA. It is the VBA equivalent of the classes you find in languages such as C# and Java.
excelmacromastery.com excelmacromastery.com
----------------

🤗
 
Upvote 0
DanteAmor said:
With the class, I'm removing all the lines you have for each commandbutton.
Every time you click on a button, the class will be executed. So in a single event you have all 28 events.

----------------
About Class Module:
learn.microsoft.com

Program with class modules

Office VBA reference topic
learn.microsoft.com

excelmacromastery.com

VBA Class Modules - The Ultimate Guide - Excel Macro Mastery

A VBA Class module is used to create your own custom objects in VBA. It is the VBA equivalent of the classes you find in languages such as C# and Java.
excelmacromastery.com excelmacromastery.com
----------------

🤗
Click to expand...
Oh Thanks for the links they are great :) I've tried the Code but after take new classand writing the first Codeline I get the follow Failure: Error when compiling only allowed in object module - In that way I search in Microsoft Sites for solving (will learn it really) I got the Message by WithEvents - in the new Modul Class1 - do I need more references?
 
Upvote 0
Pfiffikus said:
Oh Thanks for the links they are great :) I've tried the Code but after take new classand writing the first Codeline I get the follow Failure: Error when compiling only allowed in object module - In that way I search in Microsoft Sites for solving (will learn it really) I got the Message by WithEvents - in the new Modul Class1 - do I need more references?
Click to expand...
Pfiffikus said:
Oh Thanks for the links they are great :) I've tried the Code but after take new classand writing the first Codeline I get the follow Failure: Error when compiling only allowed in object module - In that way I search in Microsoft Sites for solving (will learn it really) I got the Message by WithEvents - in the new Modul Class1 - do I need more references?
Click to expand...
I do this in my free time because I normally have another job and I feel sorry for my boyfriend, he's a good guy and there's no digitization in the office. He can do a little VB but only learning by doing, so he can adapt the data sheet in the future :-)
I can't do VB either but I have a good understanding and can simplify things like this and usually implement them (in processes).
I've been reading books for weeks now, mostly in German, searching Microsoft pages and "pieced together" most of it, but also understood it (I thought :-) ). But since I'm leaving the office soon as a digitizer (all concepts and processes are finished) I want to make this easier for my colleagues. After all, there are 1400 vaccination records to check for statistical purposes (there are other solutions, but the office just doesn't understand them ;-) ). I've now translated my code into English - as well as the target table - and the data sheet. I hope you now understand a little better what I want to achieve with simple means (Excel is the only tool that is available and everyone can use it without restrictions).
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Userform inconsistent responses
Replies
1
Views
251
Candyman8019
C
P
  • Question Question
RUNTIME ERROR 91 for USERFORM CODE
Replies
1
Views
184
6StringJazzer
6StringJazzer
M
  • Question Question
Prevent worksheet change from triggering when similar macro is executed?
Replies
1
Views
188
AlphaFrog
AlphaFrog
Phil Payne
  • Solved
Changing rectangle shape colour using VBA.
Replies
2
Views
1K
Phil Payne
Phil Payne
B
  • Question Question
A simple VB Macro to change a list of Toggle Buttons color/caption once another button is clicked.
Replies
1
Views
1K
Micron
M

Forum statistics

Threads
1,226,114
Messages
6,189,052
Members
453,522
Latest member
Seeker2025

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top