Die Daten (z.B. Entfernungen der Stationen Untereinander, Kapazitäten, sonstige Restriktionen) können beliebig geändert werden. Nach dem Durchlauf des Programms erhält man die Kombinationen der kürzesten Strecken, sowie die minimalen Transportkosten.
Die Ausgangsdaten werden in folgende Tabelle eingetragen:
Die Entfernungen der Arbeitsstationen untereinander werden in folgende Tabelle eingetragen:
Die Entfernungen der Arbeitsstationen zum Depot (Lager) sowie die einzelnen Bedarfe der Arbeitsstationen aus dem Depot werden in folgende Tabelle Eingetragen.
Anschließend wird mit ALT+F11 VBA aufgerufen und das Programm gestartet. Als Ergebnis erhält man die Transportkosten, sowie die Arbeisstationen, welche zusammengefügt werden und somit in einer Tour abgefahren werden können.
VBA-Code für Excel
Public Sub saving()
Dim astationen As Integer
Dim tempKi, tempKj, tempKij As Integer
Dim Tkosten As Double
Dim Zaehler As Integer
Tkosten = Sheets("Annahmen").Cells(2, 2)
'Anzahl der Stationen ermitteln
astationen = 0
While Sheets("Depot und Bedarfe").Cells(astationen + 2, 1) <> ""
astationen = astationen + 1
Wend
'Ausgabe der Savings
Zaehler = 1
For i = 1 To astationen
For j = 2 To astationen
If i <> j And j > i Then
tempKi = Sheets("Depot und Bedarfe").Cells(i + 1, 2)
tempKj = Sheets("Depot und Bedarfe").Cells(j + 1, 2)
tempKij = Sheets("Eingabedaten").Cells(i + 1, j + 1)
ergebnisKij = (tempKi + tempKj - tempKij) * Tkosten
Sheets("Savings").Cells(Zaehler + 1, 1) = "K" & i & j
Sheets("Savings").Cells(Zaehler + 1, 2) = ergebnisKij
Sheets("Savings").Cells(Zaehler + 1, 3) = i
Sheets("Savings").Cells(Zaehler + 1, 4) = j
Zaehler = Zaehler + 1
End If
Next j
Next i
'Abarbeiten der Savings
Dim Ergebnisse As Range
Dim Max As Range
Dim Maxaddress As Range
Dim Maxsaving As String
Dim Maxaddressi, Maxaddressj As Range
Dim Maxi, Maxj As Integer
Dim Bedarfi, Bedarfj As Integer
Dim Kapazitaet As Integer
Dim ErgebnisseCollection As Collection
Set ErgebnisseCollection = New Collection
Dim savedkcollection As Collection
Set savedkcollection = New Collection
Dim addiertesavings As Integer
addiertesavings = 0
Dim saving As Integer
Kapazitaet = Sheets("Annahmen").Cells(2, 3)
For k = 1 To Zaehler
Set Ergebnisse = Sheets("Savings").Range("B2:B" & Zaehler + 1)
Set Max = AddressOfMax(Ergebnisse)
Set Maxaddressi = Max.Offset(, 1) 'Zwischenspeichern von "i" des größten Savings unter Maxaddressi
Set Maxaddressj = Max.Offset(, 2) 'Zwischenspeichern von "j" des größten Savings unter Maxaddressj
Maxi = Sheets("Savings").Cells(Maxaddressi.Row, Maxaddressi.Column) 'Zuteilung des i-Werts
Maxj = Sheets("Savings").Cells(Maxaddressj.Row, Maxaddressj.Column) 'Zuteilung des j-Werts
Bedarfi = Sheets("Depot und Bedarfe").Cells(Maxi + 1, 3) 'Zuteilung der i-Bedarfe
Bedarfj = Sheets("Depot und Bedarfe").Cells(Maxj + 1, 3) 'Zuteilung der j-Bedarfe
saving = Sheets("Savings").Cells(Max.Row, Max.Column)
Sheets("Savings").Cells(Max.Row, Max.Column) = "0"
If Bedarfi + Bedarfj <= Kapazitaet And savedkcollection.Count < astationen Then
If ErgebnisseCollection.Count > 0 Then
Dim Ergebnis As Collection
Dim z As Integer
z = 1
For Each Ergebnis In ErgebnisseCollection
'Ergebnis Count ist die Anzahl der Stellen des Ergebnisses
If Ergebnis(Ergebnis.Count) = Maxi And Ergebnis(1) <> Maxj Then
If SummeErgebnis(Ergebnis) + Sheets("Depot und Bedarfe").Cells(Maxj + 1, 3) <= Kapazitaet And inCollection(savedkcollection, Maxj) = False Then
Ergebnis.Add Maxj
savedkcollection.Add Maxj
addiertesavings = addiertesavings + saving
Else
Exit For
End If
ElseIf Ergebnis(1) = Maxi And Ergebnis(Ergebnis.Count) <> Maxj Then
If SummeErgebnis(Ergebnis) + Sheets("Depot und Bedarfe").Cells(Maxj + 1, 3) <= Kapazitaet And inCollection(savedkcollection, Maxj) = False Then
Ergebnis.Add Item:=Maxj, before:=1
savedkcollection.Add Maxj
addiertesavings = addiertesavings + saving
Else
Exit For
End If
ElseIf Ergebnis(Ergebnis.Count) = Maxj And Ergebnis(1) <> Maxi Then
If SummeErgebnis(Ergebnis) + Sheets("Depot und Bedarfe").Cells(Maxi + 1, 3) <= Kapazitaet And inCollection(savedkcollection, Maxi) = False Then
Ergebnis.Add Maxi
savedkcollection.Add Maxi
addiertesavings = addiertesavings + saving
Else
Exit For
End If
ElseIf Ergebnis(1) = Maxj And Ergebnis(Ergebnis.Count) <> Maxi Then
If SummeErgebnis(Ergebnis) + Sheets("Depot und Bedarfe").Cells(Maxi + 1, 3) <= Kapazitaet And inCollection(savedkcollection, Maxi) = False Then
Ergebnis.Add Item:=Maxi, before:=1
savedkcollection.Add Maxi
addiertesavings = addiertesavings + saving
Else
Exit For
End If
ElseIf z = ErgebnisseCollection.Count And inCollection(savedkcollection, Maxi) = False And inCollection(savedkcollection, Maxj) = False Then
Set ErgebnisSet = New Collection
ErgebnisSet.Add (Maxi)
ErgebnisSet.Add (Maxj)
savedkcollection.Add (Maxi)
savedkcollection.Add (Maxj)
addiertesavings = addiertesavings + saving
ErgebnisseCollection.Add ErgebnisSet
End If
z = z + 1
Next
Else
Set ErgebnisSet = New Collection
ErgebnisSet.Add (Maxi)
ErgebnisSet.Add (Maxj)
savedkcollection.Add (Maxi)
savedkcollection.Add (Maxj)
addiertesavings = addiertesavings + saving
ErgebnisseCollection.Add ErgebnisSet
End If
End If
Next k
For Each Ergebnis In ErgebnisseCollection
Dim strout As String
strout = "k"
For Each part In Ergebnis
strout = strout & part
Next
MsgBox ("Die Routen sind: " & strout)
Next
Dim Pendelloesung As Double
Pendelloesung = Sheets("Annahmen").Cells(2, 1)
MsgBox ("Ergebnis: " & (Pendelloesung - addiertesavings))
End Sub
Function AddressOfMax(rng As Range) As Range
Set AddressOfMax = rng.Cells(WorksheetFunction.Match(WorksheetFunction.Max(rng), rng, 0))
End Function
Function SummeErgebnis(Ergebnis As Collection) As Integer
SummeErgebnis = 0
For Each E In Ergebnis
SummeErgebnis = SummeErgebnis + Sheets("Depot und Bedarfe").Cells(E + 1, 3)
Next
End Function
Function inCollection(col As Collection, searchItem As Variant) As Boolean
inCollection = False
For Each Item In col
If Item = searchItem Then
inCollection = True
Exit For
End If
Next
End Function
Autoren: Robert Heger und Christoph Heger
Keine Kommentare:
Kommentar veröffentlichen