Jan 16, 2016, updated at Jan 19, 2016 (UTC)

6833

Excel Gewichte optimal verteilen

Hallo Experten, ich bin neu hier im Forum und habe gleich eine Frage die mich schon seit einer Woche beschäftigt ohne richtigen Erfolg.
Ich möchte das Max. Gewicht 31,5 KG aus DHL Staffelung optimal ausnutzen (mehrere Pakete).
Ich habe max. ca. 20 verschiedene Feste Gewichte die ich je nach Auftrag auf 31,5 KG Pakete verteilen möchte. Ich habe mit VBA angefangen,komme aber nicht richtig weiter. Hier ein Beispiel.

. Paket1.....Paket2.....Paket3.....usw.
Warengewicht.....Menge.....Gesamt.....Rest1
21.20 3 63.6 31.5-(2*21.2) 2 1
11.10.......................2 22.2
7.00 2 14
6.6...........................0 0
6.6 2 13.2
6.3 0 0
5.95 5 29.75
5.6 0 0
5.05..........................2 10.10
5 0 0
2.45 3 7.35
2.35 0 0
1.15 5 5,75
1.00 0 0
0.67 30 20.1
0.55 25 13.75
Ges.Gewicht 199,8
Ich bin für jeden Hinweis dankbar, egal ob Formel oder VBA Lösung.
Vielen Dang im Voraus usenussi

Please also mark the comments that contributed to the solution of the article

Content-Key: 293314

Url: https://administrator.de/contentid/293314

Printed on: April 24, 2024 at 15:04 o'clock

12 Comments

Latest comment

Servus,

such einmal nach "Bin-Packing-Problem", mit dem Zusatz der Programmiersprache findest du brauchbare Ansätze.
Das Problem ist leicht, eine etwaige Lösung leicht zu prüfen aber der Weg zur Lösung ist schwer ;)

Grüße, Stefan

Die optimale Verteilung sollte sich mit dem Excel Solver berechnen lassen...

Gruß grexit

Hallo usenussi!

Hier mal ein einfacher (mathematisch unklomplizierter) Code der zumindest anhand Deiner Beispieldaten ein brauchbares Ergebnis liefert:

Option Explicit

Private Const MaxWeight = 31.5      'Maximales Gewicht  

Private Const RowStart = 2          'Zeile: Gewichte ab Zeile ?  

Private Const ColWeight = 1         'Spalte: Gewichte  
Private Const ColCount = 2          'Spalte: Anzahl  
Private Const ColWeightSum = 3      'Spalte: Gesamtgewicht  
Private Const ColRest = 4           'Spalte: Rest  

Sub Aufteilung()
    Dim objList As Object, objPackages As Object, rngWeight As Range, objCells As Range
    Dim arrValues As Variant, strKey As Variant, dblValue As Double, dblValueSum As Double
    Dim i As Integer, x As Integer
    
    Set objList = CreateObject("Scripting.Dictionary")  
    Set objPackages = CreateObject("Scripting.Dictionary")  
    
    Set rngWeight = Range(Cells(RowStart, ColWeight), Cells(Rows.Count, ColWeight).End(xlUp))
    
    Range("E:E").ClearContents  
    rngWeight.Resize(, ColRest).Sort Key1:=rngWeight.Resize(1, 1), Order1:=xlDescending, Header:=xlNo
     
    For Each objCells In rngWeight
        For i = 1 To Cells(objCells.Row, ColCount).Value
            objList.Add objList.Count, objCells.Value
        Next
    Next
    
    If objList.Count Then
        arrValues = objList.Items
        
        For i = 0 To UBound(arrValues)
            dblValueSum = arrValues(i)
            
            If arrValues(i) <> 0 Then
                With objList
                    .RemoveAll
                    .Add dblValueSum, 1
                End With
                
                For x = i + 1 To UBound(arrValues)
                    dblValue = arrValues(x)
                    If dblValue <> 0 Then
                        If dblValueSum + dblValue <= MaxWeight Then
                            dblValueSum = dblValueSum + dblValue
                            If objList.Exists(dblValue) Then
                                objList(dblValue) = objList(dblValue) + 1
                            Else
                                objList.Add dblValue, 1
                            End If
                            arrValues(x) = 0
                        End If
                    End If
                Next
                
                For Each strKey In objList.Keys
                    objList(strKey) = objList(strKey) & " x " & Format(strKey, "0.00")  
                Next
                objPackages.Add objPackages.Count, GetValue(objPackages.Count, dblValueSum, objList.Items)
            End If
        Next
        
        With WorksheetFunction
            Cells(RowStart, "E").Resize(objPackages.Count, 1).Value = .Transpose(objPackages.Items)  
        End With
    End If
End Sub

Private Function GetValue(ByVal intCnt As Integer, ByVal dblSum As Double, ByRef objItems) As String
    GetValue = "Paket " & intCnt + 1 & " (" & Format(dblSum, "0.00") & "Kg):  " & Join(objItems, " + ")  
End Function

Ergebnis:

Gruß Dieter

Hallo Dieter,
herzlichen Dank für den Code. Es klappt prima. Du hast mir sehr geholfen. Ich wäre nie so weit gekommen und werde bestimmt ein paar Wochen brauchen um den Code zu verstehen da keine Kommentare für die Schleifen angegeben sind. Du bist eben für mich ein Profi.
Danke
Senussi

Hallo ussenussi!

OK, hier nochmal das Gleiche mit Kommentaren

Option Explicit

Private Const MaxWeight = 31.5      'Maximales Gewicht  

Private Const RowStart = 2          'Zeile: Gewichte ab Zeile ?  

Private Const ColWeight = 1         'Spalte A: Gewichte  
Private Const ColCount = 2          'Spalte B: Anzahl  
Private Const ColWeightSum = 3      'Spalte C: Gesamtgewicht (nicht Code-Relevant)  
Private Const ColRest = 4           'Spalte D: Rest (nicht Code-Relevant)  

Sub Aufteilung()
    Dim objList As Object, objPackages As Object, rngWeight As Range, objCells As Range
    Dim arrValues As Variant, strKey As Variant, dblValue As Double, dblValueSum As Double
    Dim i As Integer, x As Integer
    
    '(assoziatives)-Daten-Array für die Gewichte  
    Set objList = CreateObject("Scripting.Dictionary")  
    
    '(assoziatives)-Daten-Array für die Pakete  
    Set objPackages = CreateObject("Scripting.Dictionary")  
    
    'Zellbereichs-Object festlegen (A2:A17)  
    Set rngWeight = Range(Cells(RowStart, ColWeight), Cells(Rows.Count, ColWeight).End(xlUp))
    
    'Inhalte Spalte E löschen (Paket-Aufteilung)  
    Range("E:E").ClearContents  
    
    'Zeilen nach Gewicht absteigend (groß nach klein) sortieren  
    rngWeight.Resize(, ColRest).Sort Key1:=rngWeight.Resize(1, 1), Order1:=xlDescending, Header:=xlNo
    
    'Alle Gewichte anzahlmäßig (absteigend) in Array aufnehmen (20.2, 20.2, 20.2, ..., 0.55, 0.55)  
    For Each objCells In rngWeight
        'Nur Gewichte mit Anzahl > 0  
        For i = 1 To Cells(objCells.Row, ColCount).Value
            objList.Add objList.Count, objCells.Value
        Next
    Next
    
    'Test ob Spalte A Gewichts- und Anzahlwerte (>0) enthält  
    If objList.Count Then
        'Erfasste Gewichtsdaten in Eindimensionales Array übernehmen Item 0-78 (79 Werte)  
        arrValues = objList.Items
        
        'Gewichtsdaten-Array in Einzelschritten (Paket 1, 2 , 3, ...) durchlaufen  
        For i = 0 To UBound(arrValues)
            'Aktuellen Gewichtswert in Variable übernehmen  
            dblValueSum = arrValues(i)
            
            'Test ob aktueller Gewichtswert einen Wert <> 0 enthält  
            If arrValues(i) <> 0 Then
                'Daten-Array zurücksetzen und aktuellen Gewichtswert mit Anzahl 1 erfassen  
                With objList    'Key=Gewichtsgröße und Item=Anzahl  
                    .RemoveAll
                    .Add dblValueSum, 1
                End With
                
                'Die nachfolgenden Items bis Ende durchlaufen und gegebenenfalls Gewichte  
                'zur aktuellen Gewichtssumme dazu addieren, bis der Max-Wert erreicht ist  
                For x = i + 1 To UBound(arrValues)
                    'Jeweils nachfolgenden Wert in Variable übernehmen  
                    dblValue = arrValues(x)
                    'Test ob nachfolgender Wert <> 0  
                    If dblValue <> 0 Then
                        'Test Gewichtssumme + aktueller Gewichtswert <= Max  
                        If dblValueSum + dblValue <= MaxWeight Then
                            'Gewichtswert zur Gewichtssumme dazu addieren  
                            dblValueSum = dblValueSum + dblValue
                            
                            'Test ob aktuelle Gewichtsgröße schon mal dazu addiert wurde  
                            If objList.Exists(dblValue) Then
                                'Wenn ja Anzahl +1  
                                objList(dblValue) = objList(dblValue) + 1
                            Else
                                'Wenn nein Key=Gewichtsgröße und Item=Anzahl 1  
                                objList.Add dblValue, 1
                            End If
                            
                            'Aktuellen (dazu addierten) Gewichtswert mit 0 eliminieren  
                            arrValues(x) = 0
                        End If
                    End If
                Next
                
                'Für aktuelles Paket, einzelne Gewichtswerte mit Anzahl entsprechend formatiern  
                For Each strKey In objList.Keys
                    objList(strKey) = objList(strKey) & " x " & Format(strKey, "0.00")  
                Next
                
                'Formatierten Datensatz für aktuelles Paket in das Paket-Daten-Array aufnehmen  
                objPackages.Add objPackages.Count, GetValue(objPackages.Count, dblValueSum, objList.Items)
            End If
        Next
        
        'Alle erfassten Paketdaten in Spalte E eintragen  
        With WorksheetFunction
            Cells(RowStart, "E").Resize(objPackages.Count, 1).Value = .Transpose(objPackages.Items)  
        End With
    End If
End Sub

'Gibt einen formatierten Paket-String zurück  
Private Function GetValue(ByVal intCnt As Integer, ByVal dblSum As Double, ByRef objItems) As String
    GetValue = "Paket " & intCnt + 1 & " (" & Format(dblSum, "0.00") & "Kg):  " & Join(objItems, " + ")  
End Function

Gruß Dieter

Hallo Dieter,
vielen Dank fuer Deine Antwort.
Ist es noch möglich nachträglich eine Spalte mit Artikel1, Artikel2 usw. zu erweitern und die Ausgabe Artikel1 Menge, Gewicht in Spalten anzeigen?
Paket1...28,5 Kg
Artikel Menge Gewicht
Artikel1, ....2........11,1
usw.0
Dann wäre es gleich eine schöne Packliste mit Artikelbezeichnung.
EINEN SCHÖNEN Tag noch.
Usenussi

Hallo usenussi!

Hier der neue Code mit Paketliste, allerdings ohne Kommentare, da das ganze Array-Gestricke nach meiner Aufassung etwas schwierig zu erklären ist...

Option Explicit

Private Const MaxWeight = 31.5      'Maximales Gewicht  

Private Const RowStart = 2          'Gewichte ab Zeile ?  

Private Const ColArtikel = 1        'Spalte A: Artikel  
Private Const ColCount = 2          'Spalte B: Anzahl  
Private Const ColWeight = 3         'Spalte C: Gewicht  
Private Const ColPackages = 5       'Spalte E: Pakete  

Private Const IndexArtikel = 1      'Item-Index für Artikel  
Private Const IndexCount = 2        'Item-Index für Anzahl  
Private Const IndexWeight = 3       'Item-Index für Gewicht  

Public Sub Aufteilung2()
    Dim objList As Object, objPackages As Object, rngWeight As Range, objCells As Range
    Dim arrValues As Variant, arrItem As Variant, dblValue As Double, dblSum As Double
    Dim strArtikel As String, strPackage As String, intCount As Integer, intRowNext As Long
    Dim i As Integer, x As Integer
    
    Set objList = CreateObject("Scripting.Dictionary")  
    Set objPackages = CreateObject("Scripting.Dictionary")  
    
    Set rngWeight = Range(Cells(RowStart, ColWeight), Cells(Rows.Count, ColWeight).End(xlUp))
    
    With Columns(ColArtikel).Resize(, 3)
        .Sort Key1:=rngWeight.Resize(1, 1), Order1:=xlDescending, Header:=xlYes
    End With
    
    Cells(RowStart, ColPackages).Resize(ActiveSheet.UsedRange.Rows.Count, 4).ClearContents
    
    For Each objCells In rngWeight
        With objCells
            For i = 1 To Cells(.Row, ColCount).Value
                objList.Add objList.Count, Array(Empty, Cells(.Row, ColArtikel).Value, Empty, .Value)
            Next
        End With
    Next
    
    If objList.Count Then
        arrValues = objList.Items
        
        For i = 0 To UBound(arrValues)
            dblSum = arrValues(i)(IndexWeight)
            strArtikel = arrValues(i)(IndexArtikel)
            strPackage = "Paket " & objPackages.Count + 1 & ":"  
            
            If dblSum <> 0 Then
                intCount = 1
                With objList
                    .RemoveAll
                    .Add strPackage, Empty
                    .Add strArtikel, Array(Empty, strArtikel, 1, dblSum)
                End With
                
                For x = i + 1 To UBound(arrValues)
                    strArtikel = arrValues(x)(IndexArtikel)
                    dblValue = arrValues(x)(IndexWeight)
                    If dblValue <> 0 Then
                        If dblSum + dblValue <= MaxWeight Then
                            dblSum = dblSum + dblValue
                            If objList.Exists(strArtikel) Then
                                arrItem = objList(strArtikel)
                                arrItem(IndexCount) = arrItem(IndexCount) + 1
                                objList(strArtikel) = arrItem
                            Else
                                objList.Add strArtikel, Array(Empty, strArtikel, 1, dblValue)
                            End If
                            arrValues(x)(IndexWeight) = 0:  intCount = intCount + 1
                        End If
                    End If
                Next
                objList(strPackage) = Array(strPackage, Empty, intCount, dblSum)
                objPackages.Add objPackages.Count, objList.Items
            End If
        Next
        
        intRowNext = RowStart
        
        With WorksheetFunction
            For Each arrItem In objPackages.Items
                arrValues = .Transpose(.Transpose(arrItem))
                Cells(intRowNext, ColPackages).Resize(UBound(arrValues, 1), UBound(arrValues, 2)).Value = arrValues
                intRowNext = intRowNext + UBound(arrValues) + 1
            Next
        End With
    End If
End Sub

Ergebnis:

Gruß Dieter

[edit] in Codzeile 84 die Ziffer 5 durch die betreffende Konstante ersetzt [/edit]

Hallo Dieter,
Ich bin von Deiner Arbeit begeistert und möchte mich noch einmal ganz herzlich bedanken.
So hätte ich den Code nie hingekriegt.Vieleicht in ein paar Jahren.
Vielen Dank
Senussi

Hallo Dieter,
ich kann mit dem Hinweis "in Codezeile 84... "nichts anfangen.Der Code hat doch keine Ziffer 5. Was sollte ich in Zeile 84 ändern?
Viele Grüße
senussi

Moin (u)senussi,

Zitat von @usenussi:

ich kann mit dem Hinweis "in Codezeile 84... "nichts anfangen.Der Code hat doch keine Ziffer 5. Was sollte ich in Zeile 84 ändern?

In Dieters Code steht u.a.:

Private Const ColPackages = 5 'Spalte E: Pakete

Diese Ziffer 5 hat er in Zeile 84 konsequenterweise durch die Konstante "ColPackages" ersetzt.
Damit es nur noch an EINER Stelle im Schnipsel angepasst werden muss, wenn überhaupt.

Grüße
Biber

Hallo Biber!

Danke für's einspringen

Gruß Dieter

Hallo Dieter,

Ich habe schon Länger genau nach so einer Tabelle gesucht.
Kann man die Tabelle vom 22.01.2016 ohne großen Aufwand erweitern auf noch 2 Spalten wie Bezeichnung und Wert.
Da ich öfters Packlisten Manuell erstellen muss wäre die Tabelle die Perfekte Lösung für mich.

Viele Grüße
Karl

German solved Question VB for Applications Development

Hotly discussed

Check of ZFW Firewallgleixnerd - 5 Comments

Wireguard VPN on UDM Pro behind Fritzbox - Handshake did not completejstricker - 3 Comments

How to set up and configure a Linux GRE tunnelAlexWisha - 3 Comments