Reisezeit berechnen über 24 Stunden
22.09.2025 21:25:19
Peer
Ich habe mit meinen beschränkten VBA-Kenntnissen versucht, mit Datum und Zeitwerten zu rechnen.
Hierbei habe ich eine Userform mit folgenden Textfelder...
txt_BeginnDatum für den Tag des Beginns einer Dienstreise
txt_BeginnZeit für die Zeit des Beginns der Dienstreise
txt_EndeDatum für den Tag des Ende einer Dienstreise
txt_EndeZeit für die Zeit des Ende der Dienstreise
Weiterhin habe ich noch ein Textfeld in der UF mit dem Namen txt_Reisezeit, dass die Reisezeit anzeigen soll.
Bisher habe ich für mit meinen derzeitigen Code durchaus arbeiten können, solange ich meine Dienstreise am selben Tag beenden konnte.
Nun bin ich aber manchmal mehrere Tage weg und daher bei einem Tag auch 24 Stunden.
Der Gedanke war, dass für eine Berechnung der Verpflegungspauschale >= 24 Stunden Excel immer 00:00 errechnet und damit die Rechnung nicht aufging.
Durch meine Recherchen in Foren und im Netz habe ich erfahren, dass Excel die Datumswerte "intern" als nummerischen Wert speichert, beginnend mit dem 01.01.1900 als Wert 1, wobei der Tag vor dem Komma und die Zeit nach dem Komma ist
Jetzt habe ich versucht mit folgenden Code erstmal die Werte der Textfelder in Double-Variablen umzuwandeln, die Datum-Variablen mit den Zeit-Variablen addiere, dann die DateDiff beider errechne und dann die Zeit in Minuten (dblSumme) wieder in ein Std:Min Wert zurückrechne.
Weiterhin nehme ich den Wert der Minuten (dblSumme) für eine Berechnung der Verpflegungspauschale in einer anderen UF.
Soweit klappt beides auch.
Nun hätte ich eine Frage dazu.
Kann oder muss man den Code anderes und eventuell einfacher oder übersichtlicher schreiben?
Hier der Code der Berechnung...
Sub zeit_berechnung()
'Reisezeitberechnung
Dim Beginn As Date, ende As Date, Summe As Date
Dim dblBeginnDate As Double, dblBeginnTime As Double
Dim datBeginnTime As Date, datBeginnDate As Date
Dim datEndeTime As Date, datEndeDate As Date
Dim dblEndeDate As Double, dblEndeTime As Double
Dim dblSummeBeginn As Double, dblSummeEnde As Double, dblSumme As Double
'zur Fehlerroutine
On Error GoTo Fehler
'wenn eins der Felder leer, dann Feld Reisezeit leer und Berechnung beenden
If frm_Tag.txt_BeginnZeit = "" Or frm_Tag.txt_EndeZeit = "" Then
frm_Tag.txt_Reisezeit = ""
Exit Sub
End If
'alte Variablen
'Beginn = CDate(frm_Tag.txt_BeginnZeit)
'ende = CDate(frm_Tag.txt_EndeZeit)
'Felder als Datum auslesen und in Variablen schreiben
datBeginnDate = CDate(frm_Tag.txt_BeginnDatum) 'zB 19.02.2025
datBeginnTime = CDate(frm_Tag.txt_BeginnZeit) 'zb 09:15
datEndeDate = CDate(frm_Tag.txt_EndeDatum) 'zB 20.02.2025
datEndeTime = CDate(frm_Tag.txt_EndeZeit) 'zB 20:45
'Variablen in Ganzzahlen umwandeln
dblBeginnDate = CDbl(datBeginnDate) 'Umwandeln datBeginnDate zB 45707
dblBeginnTime = CDbl(datBeginnTime) 'Umwandeln datBeginnTime zB 0,385416666666667
dblEndeDate = CDbl(datEndeDate) 'Umwandeln datEndeDate zB 45708
dblEndeTime = CDbl(datEndeTime) 'Umwandeln datEndeTime zB 0,86458333
'Variablen zusammefügen
dblSummeBeginn = dblBeginnDate + dblBeginnTime 'Summe BeginnDatum + BeginnZeit zB 45707,385416666666667
dblSummeEnde = dblEndeDate + dblEndeTime 'Summe EndeDatum + EndeZeit zB 45708,86458333
'Debug.Print dblSummeBeginn & Chr(13) & dblSummeEnde
dblSumme = DateDiff("n", dblSummeBeginn, dblSummeEnde, vbMonday, vbFirstJan1) 'Differenz zwischen BeginnTag + EndeTag in Stunden
Debug.Print datBeginnDate & ": " & dblSumme
Debug.Print "Stunden: " & dblSumme \ 60 & " und Minuten: " & dblSumme Mod 60
Application.EnableEvents = False
' If Beginn ende Then
' Summe = DateDiff("n", Beginn, ende) / 60
' Else
' Summe = DateDiff("n", Beginn, ende) / 60 + 24
' End If
If dblSummeBeginn dblSummeEnde Then
frm_Tag.txt_Reisezeit = Format(dblSumme \ 60, "00") & ":" & Format(dblSumme Mod 60, "00")
Else
MsgBox "Hä?"
Exit Sub
End If
'frm_Tag.txt_Reisezeit = Format(CDbl(Summe) / 24, "hh:mm")
Application.EnableEvents = True
Exit Sub
Fehler:
MsgBox "Falscher Wert", vbOKOnly, "Fehlermeldung Zeiteingabe"
End Subund hier der Code für die Berechnung der Verpflegungspauschale in einer ListBox
' ListBox mit Daten von allen Sheets füllen mit Hilfe von ralf_b von herber.de ------
Dim lngMonth As Long, ialngIndex As Long, lngRow As Long
Dim datBeginnDate As Date, datBeginnTime As Date, dblBeginnDate As Double, dblBeginnTime As Double
Dim datEndeDate As Date, datEndeTime As Date, dblEndeDate As Double, dblEndeTime As Double
Dim dblBeginnSumme As Double, dblEndeSumme As Double
Dim lngColumn As Long, lngDauer As Long, dblDauer As Double
Dim datBeginn As Date, datEnde As Date, strBeginnOrt As String
Dim strEndeOrt As String, strReiseOrt As String
Dim avntValues() As Variant, avntTemp As Variant, vntItem As Variant
Dim datAbgabe As Date, datAnnahme As Date, datGezahlt As Date
'On Error GoTo Fehler
For lngMonth = 1 To 12 'auf 12 Monate erhöhen!!!
lngRow = 11 'Beginn bei Zeile 12
With Worksheets(MonthName(Month:=lngMonth))
Do
If IsEmpty(.Cells(lngRow + 1, 26).Value) Then
lngRow = .Cells(lngRow, 26).End(xlDown).Row
Else
lngRow = lngRow + 1
End If
If lngRow .Rows.Count Then
'Festlegung der Listenspalten (hier 12)
ReDim Preserve avntValues(12, ialngIndex)
lngColumn = 0
'Beginn in Zahl umrechnen
datBeginnDate = CDate(.Cells(lngRow, "AA"))
' Debug.Print datBeginnDate
datBeginnTime = CDate(.Cells(lngRow, "AB"))
' Debug.Print datBeginnTime
dblBeginnDate = CDbl(datBeginnDate)
' Debug.Print dblBeginnDate
dblBeginnTime = CDbl(datBeginnTime)
' Debug.Print dblBeginnTime
dblBeginnSumme = CDbl(dblBeginnDate + dblBeginnTime)
' Debug.Print "Anfang: " & dblBeginnSumme
'Ende in Zahl umrechnen
datEndeDate = CDate(.Cells(lngRow, "AD"))
' Debug.Print datBeginnDate
datEndeTime = CDate(.Cells(lngRow, "AE"))
' Debug.Print datBeginnTime
dblEndeDate = CDbl(datEndeDate)
' Debug.Print dblBeginnDate
dblEndeTime = CDbl(datEndeTime)
' Debug.Print dblBeginnTime
'Summe in Zahl umrechnen
dblEndeSumme = CDbl(dblEndeDate + dblEndeTime)
' Debug.Print "Ende: " & dblEndeSumme
'Dauer in Stunden rechnen
dblDauer = DateDiff("h", dblBeginnSumme, dblEndeSumme, vbMonday, vbFirstJan1)
' Debug.Print "Dauer: "; datBeginnDate & "| " & dblDauer & " Stunden"
' Select Case dblDauer
' Case Is = 8
' MsgBox "Unter 8 Stunden"
'' Case Is > 8, Is 14
'' MsgBox "Über 8 aber unter 14 Stunden"
'' Case Is > 14, Is 24
'' MsgBox "Unter 24 Stunden aber über 14 Stunden"
' Case Is >= 24
' MsgBox "Gleich oder über 24 Stunden"
' End Select
datBeginn = CDate(.Cells(lngRow, "AA")) + CDate(.Cells(lngRow, "AB"))
' Debug.Print datBeginn
datEnde = CDate(.Cells(lngRow, "AD")) + CDate(.Cells(lngRow, "AE"))
lngDauer = DateDiff("h", datBeginn, datEnde)
' Debug.Print lngDauer
strBeginnOrt = Left(.Cells(lngRow, "AC"), 1)
strEndeOrt = Left(.Cells(lngRow, "AF"), 1)
datAbgabe = .Cells(lngRow, "AH").Value
datAnnahme = .Cells(lngRow, "AI").Value
datGezahlt = .Cells(lngRow, "AJ").Value
'Werte für Spalten 1-8 aus Spalte 26 bis 32 Sheets
avntTemp = .Range(.Cells(lngRow, 26), .Cells(lngRow, 35)).Value
'Array Spaltengröße erhöhen und 2 Spalten hinzufügen
ReDim Preserve avntTemp(1 To 1, UBound(avntTemp, 2) + 1)
avntTemp(1, 7) = .Cells(lngRow, "AE") - .Cells(lngRow, "AB").Value '(Dauer)
avntTemp(1, 9) = datAbgabe
avntTemp(1, 10) = datAnnahme
avntTemp(1, 11) = datGezahlt
'Anhand der Dauer Wert in Spalte 8 (Kosten) festlegen
Select Case dblDauer 'lngDauer
Case Is = 8 'der Wert = 8 Stunden (480 min)
avntTemp(1, 8) = "00,00 €"
Case Is >= 24 '4 Stunden (1140 min)
avntTemp(1, 7) = "24:00"
If strBeginnOrt = "A" Or strEndeOrt = "A" Then
avntTemp(1, 8) = "40,00 €"
ElseIf strBeginnOrt = "I" Or strEndeOrt = "I" Then
avntTemp(1, 8) = "40,00 €"
Else
avntTemp(1, 8) = "28,00 €"
End If
Case Is > 8
If strBeginnOrt = "A" Or strEndeOrt = "A" Then
avntTemp(1, 8) = "27,00 €"
ElseIf strBeginnOrt = "I" Or strEndeOrt = "I" Then
avntTemp(1, 8) = "27,00 €"
Else
avntTemp(1, 8) = "14,00 €"
End If
Case Else
avntTemp(1, 8) = "Fehler"
Debug.Print vntItem
End Select
For Each vntItem In avntTemp
Select Case lngColumn
Case 2, 5, 7
avntValues(lngColumn, ialngIndex) = Format$(vntItem, "Hh:Nn")
lngColumn = lngColumn + 1
Case Else
avntValues(lngColumn, ialngIndex) = vntItem
lngColumn = lngColumn + 1
End Select
Next
'schreibt den Tabellennamen und die Zeile getrennt durch ein Pipe in das Array
'wird für das Click-Event lst_Dienstreise benötigt
avntValues(12, ialngIndex) = MonthName(Month:=lngMonth) & "|" & CStr(lngRow)
ialngIndex = ialngIndex + 1
Else
Exit Do
End If
Loop
End With
Next
'Fehler abfangen, wenn ListBox leer bleibt
If ialngIndex = 0 Then
MsgBox "Es sind in diesem Jahr noch keine Reisen vorhanden", vbOKOnly + vbInformation, "Meldung"
Exit Sub
End IfVielleicht finden die Profis eine Lösung.
In jedem Fall bin ich dankbar für Ideen.
Vielen Dank
Peer
Anzeige