My code contains two buttons, but only one button works correctly

alex345boy 0
Viewed 44

First, I want to state, that I am by far no professional, maybe an amateur, so I would really appreciate, if you could give some basic feedback on my coding if you want of course. I think, that would be a good way of learning to code :)

I am a logistics student and I have learned quite a bit of vba coding in class we had last year.

I started as a working student last week and I have to track my hours, so I tried to code a programm in VBA, which opens an excel worksheet, the user types in the starting day month and year, in the "non-american" way --> 01.09.2022 instead of 09/01/2022. After that, the vba automatically fills in a table with the dates and the weekdays according to the given date. I added some additional codings like graying out all weekends and stuff.

My problem lies in the buttons. I used two buttons, but only one of them is working. The button should run the exact same sub it is placed in, to reactivate the code, when the month passed. Unfortunately somehow, it doesnt recognise the button as a button, I think the macro wont bind to it? I have a second button, which mutliplies the hours worked with an hour-based salary the user enters, to see how much money was made :)

My code:

Sub Tabelle()

    Worksheets.Add
    
    Dim Eingabe As String, T As Integer, Tag As Integer, Z As Long, b As Excel.Shape, Lohn As Double, btn As Excel.Shape

    
    Eingabe = InputBox("Geben Sie bitte das Anfangsdatum des Monats an, z.B. 01.09.2022")
    
    ActiveSheet.Name = "Zeiterfassung " & Eingabe
    
    'Tagesanzahl für eingegebenen Monat finden
    If Mid(Eingabe, 4, 2) = "01" Then T = 31
    If Mid(Eingabe, 4, 2) = "02" Then T = 29
    If Mid(Eingabe, 4, 2) = "03" Then T = 31
    If Mid(Eingabe, 4, 2) = "04" Then T = 30
    If Mid(Eingabe, 4, 2) = "05" Then T = 31
    If Mid(Eingabe, 4, 2) = "06" Then T = 30
    If Mid(Eingabe, 4, 2) = "07" Then T = 31
    If Mid(Eingabe, 4, 2) = "08" Then T = 31
    If Mid(Eingabe, 4, 2) = "09" Then T = 30
    If Mid(Eingabe, 4, 2) = "10" Then T = 31
    If Mid(Eingabe, 4, 2) = "11" Then T = 30
    If Mid(Eingabe, 4, 2) = "12" Then T = 31
    
    'Datum erstellen in Spalte 1
    Tag = Left(Eingabe, 2)
    
    For i = 3 To (T + 2)
        Cells(i, 1) = Format(Tag, "00") & "." & Mid(Eingabe, 4, 99)
        Tag = Tag + 1
    Next i
    
    'Wochentage für jedes Datum eintragen in Spalte 2
    i = 3
    Do While Cells(i, 1) <> ""
        If Weekday(Cells(i, 1)) = 1 Then Cells(i, 2) = "Sonntag"
        If Weekday(Cells(i, 1)) = 2 Then Cells(i, 2) = "Montag"
        If Weekday(Cells(i, 1)) = 3 Then Cells(i, 2) = "Dienstag"
        If Weekday(Cells(i, 1)) = 4 Then Cells(i, 2) = "Mittwoch"
        If Weekday(Cells(i, 1)) = 5 Then Cells(i, 2) = "Donnerstag"
        If Weekday(Cells(i, 1)) = 6 Then Cells(i, 2) = "Freitag"
        If Weekday(Cells(i, 1)) = 7 Then Cells(i, 2) = "Samstag"
        
        i = i + 1
    Loop
    
    Z = 3
    
    Do While Cells(Z, 2) <> ""
        If Cells(Z, 2) = "Samstag" Or Cells(Z, 2) = "Sonntag" Then
            Cells(Z, 1).Interior.ColorIndex = 6
            Cells(Z, 2).Interior.ColorIndex = 6
            Cells(Z, 3).Interior.ColorIndex = 6
            Cells(Z, 4).Interior.ColorIndex = 6
            Cells(Z, 5).Interior.ColorIndex = 6
            Cells(Z, 6).Interior.ColorIndex = 6
        End If
        Z = Z + 1
    Loop
   
    'Code für Stunden gearbeitet
    For i = 3 To (T + 2)
        Cells(i, 5) = "=" & "(D" & i & "-" & "C" & i & ") * 24"
    Next i
    
    'Button für neuen Monat
    Set b = ActiveSheet.Shapes.AddFormControl(xlButtonControl, 265, 500, 100, 50)
    b.OnAction = "Tabelle"
    b.OLEFormat.Object.Text = "Nächster Monat"
    
    Set btn = ActiveSheet.Shapes.AddFormControl(xlButtonControl, 300, 470, 100, 50)
    b.OnAction = "Testing"
    b.OLEFormat.Object.Text = "Entgelt aktualisieren"
        
    Range("C34").FormulaLocal = "=Summe(E3:E33)-Summe(F3:F33)"
    Range("A35") = "Entgelt"
    
    Lohn = InputBox("Geben Sie ihren Stundenlohn ein!")
    Range("A40") = "Stundenlohn"
    Range("B40") = Format(Lohn, "00.00 €")
    
     Range("A3:F" & T + 2).BorderAround LineStyle:=xlContinuous, Weight:=xlThick
    Range("A2:F2").BorderAround LineStyle:=xlContinuous, Weight:=xlThick
    Range("A2") = "Datum"
    Range("B2") = "Tag"
    Range("C2") = "Von"
    Range("D2") = "Bis"
    Range("E2") = "Std."
    Range("F2") = "Pause in Std."
    Range("A34") = "Stunden gesamt"
    
    
    
    
    
End Sub

Sub Testing()
    

    Range("C35") = Format(Left(Range("C34"), 2) * Range("B40"), "#,#00.00 €")
    

End Sub

Picture of the Worksheet 1

Picture of the Worksheet 2

The lower button is working btw.

button encoding vba excel
1 Answers

Please, try the next optimized code:

Sub Tabelle()
  Dim ws As Worksheet, rngA As Range, rngB As Range, Eingabe As String
  Dim minD As Date, maxD As Date, arrD, arrTags, arrCol, rngCol As Range, i As Long
  Dim boolYearEnd As Boolean: If Month(Date) = 12 Then boolYearEnd = True
  
  Worksheets.Add
  Set ws = ActiveSheet 'set the added sheet
  
  'it proposes the first day of the next month (it ca be easily modified):
  Eingabe = InputBox("Geben Sie bitte das Anfangsdatum des Monats an, z.B. 01.09.2022", _
                     "Date input", Format(DateSerial(IIf(boolYearEnd, Year(Date) + 1, Year(Date)), _
                                         IIf(boolYearEnd, 1, Month(Date) + 1), 1), "dd.mm.yyyy"))
   If IsDate(Eingabe) Then
        minD = DateValue(Eingabe) ' if a correct input, it is converted to date
    Else
        MsgBox "The input (" & Eingabe & ") is not a correct date, please enter a correct one in the recommended format...": Exit Sub
    End If
    
    maxD = WorksheetFunction.EoMonth(minD, 0) 'set the end of the above month entered
    
    arrD = Evaluate("row(" & CLng(minD) & ":" & CLng(maxD) & ")") 'create an array of the necessary Date
    Set rngA = Range("A3").Resize(UBound(arrD), 1)                'set the range where to drop the array content
    
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual 'Optimization to make the code faster
    With rngA
        With .rows(1).Resize(, 6).Offset(-1) 'add headers and format a little:
            .Value = Array("Datum", "Tag", "Von", "Bis", "Std.", "Pause in Std.")
            .BorderAround LineStyle:=xlContinuous, Weight:=xlThick
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThick
        End With
        .Value = arrD
        .NumberFormat = "dd.mm.yyyy"
        .Offset(, 1).Formula2 = "=TagName(" & .cells(1).Address(0, 0) & ")"       'fill also the days name in the next column
        .Offset(, 4).Formula2 = "=(D" & .cells(1).row & "-C" & .cells(1).row & ")*24" 'place the formula to calculate hours difference
        .Offset(, 1).Value = .Offset(, 1).Value                                    'transform formula in value
        Set rngB = .Offset(, 1)                                                                                               'set rngB as next column Offset
    End With
    
    arrCol = rngB.Value2                 'place B:B column in an array, for faster iteration/processing
    For i = 1 To UBound(arrCol)
        If arrCol(i, 1) = "Samstag" Or arrCol(i, 1) = "Sonntag" Then
            addToRange rngCol, rngB(i).Offset(, -1).Resize(, 6) 'create a Union range to color it at once (very fast)
        End If
    Next i
    If Not rngCol Is Nothing Then rngCol.Interior.ColorIndex = 6
    
    'insert the two necessary buttons:
    With ws.Shapes.AddFormControl(xlButtonControl, 270, 500, 100, 50)
        .OnAction = "Tabelle": .OLEFormat.Object.Text = "Nächster Monat"
    End With
    With ws.Shapes.AddFormControl(xlButtonControl, 270, 440, 100, 50)
        .OnAction = "Testing": .OLEFormat.Object.Text = "Entgelt aktualisieren"
    End With
    
    'add other necessary data:
    ws.Range("A35") = "Entgelt"
    ws.Range("C34").FormulaLocal = "=Summe(E3:E33)-Summe(F3:F33)"
    
    Dim Lohn As String
    Lohn = InputBox("Geben Sie ihren Stundenlohn ein!")
    ws.Range("A40").Value = "Stundenlohn"
    ws.Range("B40").Value = Format(Lohn, "00.00 €")
    
    With rngA.Resize(, 6)                                                                             'a little format for the 6 involved columns
            .EntireColumn.AutoFit
            .BorderAround LineStyle:=xlContinuous, Weight:=xlThick
            .Borders(xlInsideVertical).Weight = xlThin
    End With
    
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic 'Optimization to make the code faster
    MsgBox "Ready..."
End Sub

Function TagName(d As Date) As String 'function to return the day name for a specific date
    Dim arrT: arrT = Split("Sonntag,Montag,Dienstag,Mittwoch,Donnerstag,Freitag,Samstag", ",")
    
    TagName = arrT(WorksheetFunction.Weekday(d, vbSunday) - 1)
End Function

Private Sub addToRange(rngU As Range, rng As Range) 'function to create the Union range
    If rngU Is Nothing Then
        Set rngU = rng
    Else
        Set rngU = Union(rngU, rng)
    End If
End Sub
FaneDuru0
Related