Fahrzeugzuordnung

Liebes Forum,
ich stehe vor folgendem Problem:
Ich möchte verschiedene Taxifahrten einzelnen Taxis zuordnen unter Berücksichtigung des Zeitfensters der Fahrt, sowie der gefahrenen Strecke und einer pauschalen Pausenzeiten nach jeder Fahrt.
Ausgangssituation (siehe Tabelle Beispieldatei)
https://www.herber.de/bbs/user/126100.xlsx
Mir liegt eine Tabelle 1 Fahrten mit verschiedenen Taxifahrten vor:
Spalte A Fahrtnummer
Spalte B Fahrzeugtyp (klein, mittel, groß Ganzzahl 1,2,3)
Spalte C Startzeitpunkt (Datum & Uhrzeit - TT.MM.JJJJ hh:mm)
Spalte D Endzeitpunkt (Datum & Uhrzeit - TT.MM.JJJJ hh:mm)
Spalte E Entfernung (km - Double)
Tabelle 2 Parameter:
Zelle B1 (Konstante Verbrauch pro km l/km Double z.B. 5l/100km = 0,05l/km)
Zelle B2 (Konstante Kilometerpauschale Euro/km Double z.B. 0,30)
Zelle B3 (Konstante Zeitpauschale Euro/Stunde Double z.B. 10)
Zelle B4 (Konstante Pausenzeit hh:mm z.B. 0:15 für 15 Minuten)
Tabelle 3 Taxis Fahrzeugtyp 1 (Fahrzeuge)
Spalte A Fahrzeugnummer
Spalte B Auflistung Fahrtennummern
Spalte C Fahrzeit (summiert [hh]:mm)
Spalte D Kilometer (summiert km Double)
Spalte E Verbrauch (ermittelt aus km Tabelle 1 und Verbrauch Konstante Tabelle 2 Liter Double)
Spalte F Verdienst (ermittelt aus km Tabelle 1 und Kilometerpauschale Konstante und Zeitpauschale Tabelle 2 Euro Double)
Ziel soll es sein, die Fahrten (Tabelle 1) auf die Taxis Tabelle 3 aufzuteilen und den Verbrauch der Taxis, als auch den Verdienst (über Kilometerpauschale) zu ermitteln. So müsste die Tabelle 1 zunächst nach Fahrzeugtypen aufgeteilt werden (1,2,3). Danach müsste jede der drei neuen Listen nach dem Startzeitpunkt aufsteigend sortiert werden (05:30, 5:33 etc.). Es folgt eine Aufteilung auf die Fahrzeuge, mit der Bedingung, dass sofern ein Fahrzeug wieder am Taxistand ist und dessen Endzeitpunkt (Tabelle 1) inklusive der pauschalen Pausenzeit (Tabelle 2) vor dem Startzeitpunkt liegt, die Fahrt auf das Fahrzeug gelegt wird und die Parameter summiert werden. Gibt es keine verfügbares Fahrzeug, wird ein neues Fahrzeug verwendet.
Beispiel:
Fahrt 1; klein 1; 05:30 - 06:12 Uhr ;60 km
Fahrt 2; klein 1 ; 05:50 - 06:10 Uhr; 30 km
Fahrt 3; mittel 2; 05:40 - 06:05 Uhr; 35 km
Fahrt 4; klein 1; 06:30 - 6:45 Uhr: 12 km
Die Fahrten 1, 2 und 3 entsprechen Typ 1 und werden wie folgt auf Fahrzeuge aufgeteilt:
Fahrzeug 1 wird Fahrt 1 zugeordnet
Fahrzeug 2 wird Fahrt 2 und Fahrt 4 zugeordnet, da Fahrzeug 2 vor Fahrzeug 1 am Taxistand ist und der Startzeitpunkt nach dem Endzeitpunkt inklusive Pause liegt (06:10+00:15 = 06:25), ansonsten wäre die Fahrt einem weitere Fahrzeug zuzuordnen.
Fahrt 4 entspricht einem anderen Typ und wird z.B. in Tabelle 4 ähnlich wie bei Typ 1 behandelt.
Im Ergebnis hätten wir 2 Tabellen (1 je Fahrzeugtyp) mit folgenden Informationen.
Tabelle 3 Taxis Fahrzeugtyp 1
Fahrzeug 1; Fahrt 1; 00:42; 60 km; (60 km*0,05 l/km)=3l;(60 km*0,30 /km)=18,00 + (42 min/60 min*10 /h)= 7 )
Nur Werte: 1; 1; 00:42; 60; 3; 25
Fahrzeug 2; Fahrt 2, Fahrt 4; (00:20+00:15)=00:35; (30 km+12 km)=42 km; 42 km*0,05 l/km)=2,1 l; (42 km*0,30 /km)=12,60 + (35 min/60 min*10 /h)= 5,38 )
Nur Werte: 2; 2, 4; 00:35; 42; 2,1; 18,43
Tabelle 4 Taxis Fahrzeugtyp 2
Fahrzeug 1; Fahrt 3; 00:25; 35 km; (35 km*0,05 l/km)=1,75 l;(35 km*0,30 /km)=10,50 + (25 min/60 min*10 /h)= 4,17 )
Nur Werte: 1; 3; 00:25; 35; 1,75; 4,17
Ich vermute, dass dies über eine Schleife in VBA programmiert werden kann, stehe allerdings auf dem Schlauch, wie ich die einzelnen Bedingungen und Parameter integrieren bzw. Berücksichtigen kann. Das Anwenden der Sortierfunktion und das Übertragen in neue Tabelle bekomme ich noch hin, jedoch das Überprüfen, mit der Endzeit und das Austauschen bzw. ergänzen der Variablen um eine ansteigenden Wert leider nicht.
Über jede Hilfe oder Hinweise wäre ich äußerst dankbar.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Taxi() Dim TBO, TBF, TBP, TBF1, TBF2, TBF3 Dim LR As Double, Z1 As Integer, i As Double, Fzg As Integer Dim WF, Zeile As Integer, Zuerst As Date, Zi As Integer Set TBO = Sheets("Fahrten") Set TBP = Sheets("Parameter") Set TBF1 = Sheets("Taxis Fahrzeugtyp 1") Set TBF2 = Sheets("Taxis Fahrzeugtyp 2") Set TBF3 = Sheets("Taxis Fahrzeugtyp 3") Set WF = WorksheetFunction Z1 = 2 Application.ScreenUpdating = False 'temporäres Blatt anlegen TBO.Copy Before:=Sheets(1) Set TBF = ActiveSheet 'das Neue With TBF 'umbenennen .Name = "Arbeitsblatt" 'letzte Zeile der Spalte LR = .Cells(.Rows.Count, 1).End(xlUp).Row 'Sortieren nach Startzeit, Fahrt .Sort.SortFields.Add2 Key:=.Columns(3), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal .Sort.SortFields.Add2 Key:=.Columns(1), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal .Sort.SetRange .UsedRange With .Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With 'Frei ab eintragen .Cells(1, 6) = "Frei ab" With .Cells(Z1, 6).Resize(LR - Z1 + 1, 1) .FormulaR1C1 = "=RC[-2]+" & TBP.Name & "!R4C2" .NumberFormat = "DD.MM.YYYY hh:mm" .Value = .Value End With 'Fahrzeit .Cells(1, 7) = "Fahrzeit" With .Cells(Z1, 7).Resize(LR - Z1 + 1, 1) .FormulaR1C1 = "=RC[-3]-RC[-4]" .NumberFormat = "[h]:mm" .Value = .Value End With 'Verbrauch .Cells(1, 8) = "Verbrauch" With .Cells(Z1, 8).Resize(LR - Z1 + 1, 1) .FormulaR1C1 = "=RC[-3]*" & TBP.Name & "!R1C2" .NumberFormat = "0.00" .Value = .Value End With 'Verdienst .Cells(1, 9) = "Verdienst" With .Cells(Z1, 9).Resize(LR - Z1 + 1, 1) .FormulaR1C1 = "=RC[-4]*" & TBP.Name & "!R2C2+RC[-2]*" & TBP.Name & "!R3C2" .NumberFormat = "#,##0.00 $" .Value = .Value End With .Cells(1, 10) = "Fahrzeugnummer" .Cells(1, 12) = "Fahrzeug unterwegs" .Cells(1, 13) = "Frei ab" .Columns(13).NumberFormat = "DD.MM.YYYY hh:mm" Zi = 2 For i = Z1 To LR 'Fahrzeug ermitteln, welches zuerst zurück ist Zuerst = WF.Min(.Columns(13)) If Zuerst > 0 And Zuerst <= .Cells(i, 3) Then 'Ist ein Fahrzeug verfügbar? 'Zeile des Fzg, dass zuerst zurück war Zeile = WF.Match(CDbl(Zuerst), .Columns(13), 0) 'Fzg, dass zuerst zurück war neu zuweisen .Cells(i, 10) = .Cells(Zeile, 12) 'Fzg in Temporären Spalten updaten .Cells(Zeile, 12) = .Cells(i, 10) .Cells(Zeile, 13) = .Cells(i, 6) Zi = Zi + 1 Else 'Neues Fahlzeug zuweisen .Cells(i, 10) = WF.Max(Columns(10)) + 1 'Fahrzeug in Temporäre Spalten schreiben .Cells(Zi, 12) = .Cells(i, 10) .Cells(Zi, 13) = .Cells(i, 6) Zi = Zi + 1 End If Next i 'Spaltenbreite .Cells.EntireColumn.AutoFit End With 'Verteilen auf Einzelblätter For i = 1 To 3 With Sheets("Taxis Fahrzeugtyp " & i) If TBF.AutoFilterMode Then TBF.AutoFilterMode = False ' Autofilter ausschalten 'Filtern nach FzgTyp TBF.Columns(2).AutoFilter Field:=1, Criteria1:="=" & i, _ Operator:=xlOr, Criteria2:="=" 'reset .Cells.ClearContents TBF.Cells(1, 10).Resize(LR, 1).Copy .Cells(1, 1) 'Fzgnummer TBF.Cells(1, 1).Resize(LR, 1).Copy .Cells(1, 2) 'Fahrtnr. TBF.Cells(1, 7).Resize(LR, 1).Copy .Cells(1, 3) 'Zeit TBF.Cells(1, 5).Resize(LR, 1).Copy .Cells(1, 4) 'km TBF.Cells(1, 8).Resize(LR, 1).Copy .Cells(1, 5) 'Verbrauch TBF.Cells(1, 9).Resize(LR, 1).Copy .Cells(1, 6) 'Verdienst 'Sortieren nach Fahrzeug .Sort.SortFields.Add2 Key:=.Columns(1), SortOn:=xlSortOnValues, _ Order:=xlAscending, DataOption:=xlSortNormal .Sort.SetRange .UsedRange With .Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With Next i TBF.AutoFilterMode = False ' Autofilter ausschalten End Sub

wenn der ursprüngliche Fahlzeugtyp auch bei weiteren Fahrtzuweisungen berücksichtigt werden soll
dann so...
Modul1

Option Explicit 
 
 
Sub Taxi() 
    Dim TBO, TBF, TBP, TBF1, TBF2, TBF3 
    Dim LR As Double, Z1 As Integer, i As Double, Fzg As Integer 
    Dim WF, Zeile As Integer, Zuerst As Date, Zi As Integer 
     
    Set TBO = Sheets("Fahrten") 
    'Set TBO = Sheets("FahrtenTest") 'für Kurztest 
    Set TBP = Sheets("Parameter") 
    Set TBF1 = Sheets("Taxis Fahrzeugtyp 1") 
    Set TBF2 = Sheets("Taxis Fahrzeugtyp 2") 
    Set TBF3 = Sheets("Taxis Fahrzeugtyp 3") 
    Set WF = WorksheetFunction 
     
    Z1 = 2 
     
    Application.ScreenUpdating = False 
     
    'Temporäres Blatt löschen 
    On Error Resume Next 
    Application.DisplayAlerts = False 
    Sheets("Arbeitsblatt").Delete 
    Application.DisplayAlerts = True 
    On Error GoTo Fehler 
     
     
    'temporäres Blatt anlegen 
    TBO.Copy Before:=Sheets(1) 
    Set TBF = ActiveSheet 'das Neue 
     
    With TBF 
        'umbenennen 
        .Name = "Arbeitsblatt" 
         
         'letzte Zeile der Spalte 
        LR = .Cells(.Rows.Count, 1).End(xlUp).Row 
         
        'Sortieren nach Startzeit, Fahrt 
        .Sort.SortFields.Add2 Key:=.Columns(3), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal 
        .Sort.SortFields.Add2 Key:=.Columns(1), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal 
        .Sort.SetRange .UsedRange 
         With .Sort 
           .Header = xlYes 
            .MatchCase = False 
            .Orientation = xlTopToBottom 
            .SortMethod = xlPinYin 
            .Apply 
        End With 
 
         
        'Frei ab eintragen 
        .Cells(1, 6) = "Frei ab" 
        With .Cells(Z1, 6).Resize(LR - Z1 + 1, 1) 
            .FormulaR1C1 = "=RC[-2]+" & TBP.Name & "!R4C2" 
            .NumberFormat = "DD.MM.YYYY hh:mm" 
            .Value = .Value 
        End With 
         
        'Fahrzeit 
       .Cells(1, 7) = "Fahrzeit" 
        With .Cells(Z1, 7).Resize(LR - Z1 + 1, 1) 
            .FormulaR1C1 = "=RC[-3]-RC[-4]" 
            .NumberFormat = "[h]:mm" 
            .Value = .Value 
        End With 
     
     
        'Verbrauch 
       .Cells(1, 8) = "Verbrauch" 
        With .Cells(Z1, 8).Resize(LR - Z1 + 1, 1) 
            .FormulaR1C1 = "=RC[-3]*" & TBP.Name & "!R1C2" 
            .NumberFormat = "0.00" 
            .Value = .Value 
        End With 
     
        'Verdienst 
       .Cells(1, 9) = "Verdienst" 
        With .Cells(Z1, 9).Resize(LR - Z1 + 1, 1) 
            .FormulaR1C1 = "=RC[-4]*" & TBP.Name & "!R2C2+RC[-2]*" & TBP.Name & "!R3C2" 
            .NumberFormat = "#,##0.00 $" 
            .Value = .Value 
        End With 
     
        .Cells(1, 10) = "Fahrzeugnummer" 
        .Cells(1, 12) = "Fahrzeug unterwegs" 
        .Cells(1, 13) = "Frei ab" 
        .Columns(13).NumberFormat = "DD.MM.YYYY hh:mm" 
        .Cells(1, 14) = "Typ" 
        .Cells(1, 15) = "Suchschlüssel" 
         
 
        Zi = 2 
         
        For i = Z1 To LR 
             'Fahrzeug ermitteln, welches zuerst zurück ist und gleichen Typ hat 
             Zuerst = WF.MinIfs(.Columns(13), .Columns(14), .Cells(i, 2)) 
             
            If Zuerst > 0 And Zuerst <= .Cells(i, 3) Then 'Ist ein Fahrzeug verfügbar? 
             
                'Zeile des Fzg, dass zuerst zurück war und gleichen Typ hat 
                Zeile = WF.Match(CDbl(Zuerst) + (.Cells(i, 2) * 100000), .Columns(15), 0) 
                 
                'Fzg, dass zuerst zurück war neu zuweisen 
                .Cells(i, 10) = .Cells(Zeile, 12) 
                 
                'Fzg in Temporären Spalten updaten 
                '.Cells(Zeile, 12) = .Cells(i, 10) 
                .Cells(Zeile, 13) = .Cells(i, 6) 
                '.Cells(Zeile, 14) = .Cells(i, 2) 
                .Cells(Zeile, 15) = CDbl(.Cells(Zeile, 13)) + (.Cells(Zeile, 2) * 100000) 
                 
            Else 
                 'Neues Fahlzeug zuweisen 
                 .Cells(i, 10) = WF.Max(.Columns(10)) + 1 
                 
                'Fahrzeug in Temporäre Spalten schreiben 
                .Cells(Zi, 12) = .Cells(i, 10) 
                .Cells(Zi, 13) = .Cells(i, 6) 
                .Cells(Zi, 14) = .Cells(i, 2) 
                .Cells(Zi, 15) = CDbl(.Cells(Zi, 13)) + (.Cells(i, 2) * 100000) 
                Zi = Zi + 1 
                 
            End If 
        Next i 
     
        'Suchschlüssel löschen 
        .Columns(15).ClearContents 
         
        'Spaltenbreite 
        .Cells.EntireColumn.AutoFit 
    End With 
     
    'Verteilen auf Einzelblätter 
    For i = 1 To 3 
        With Sheets("Taxis Fahrzeugtyp " & i) 
            If TBF.AutoFilterMode Then TBF.AutoFilterMode = False ' Autofilter ausschalten 
             
            'Filtern nach FzgTyp 
            TBF.Columns(2).AutoFilter Field:=1, Criteria1:="=" & i, _
                Operator:=xlOr, Criteria2:="=" 
     
            'reset 
            .Cells.ClearContents 
            TBF.Cells(1, 10).Resize(LR, 1).Copy .Cells(1, 1) 'Fzgnummer 
            TBF.Cells(1, 1).Resize(LR, 1).Copy .Cells(1, 2)  'Fahrtnr. 
            TBF.Cells(1, 7).Resize(LR, 1).Copy .Cells(1, 3)  'Zeit 
            TBF.Cells(1, 5).Resize(LR, 1).Copy .Cells(1, 4)  'km 
            TBF.Cells(1, 8).Resize(LR, 1).Copy .Cells(1, 5)  'Verbrauch 
            TBF.Cells(1, 9).Resize(LR, 1).Copy .Cells(1, 6)  'Verdienst 
             
             
            'Sortieren nach Fahrzeug 
            .Sort.SortFields.Add2 Key:=.Columns(1), SortOn:=xlSortOnValues, _
                Order:=xlAscending, DataOption:=xlSortNormal 
            .Sort.SetRange .UsedRange 
             With .Sort 
                .Header = xlYes 
                .MatchCase = False 
                .Orientation = xlTopToBottom 
                .SortMethod = xlPinYin 
                .Apply 
            End With 
 
             
        End With 
    Next i 
     
    TBF.AutoFilterMode = False ' Autofilter ausschalten 
     
    'Fertig 
    MsgBox WF.Max(TBF.Columns(10)) & " Fahrzeuge im Einsatz!", vbOKOnly, "Fertig" 
     
    '*** Fehlerbehandlung 
    Err.Clear 
Fehler: 
    Application.EnableEvents = True 
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear 
End Sub

LG UweD
Ein gute Flasche Wein müsste schon drin sein.

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread