594 Aufrufe
Gefragt in Tabellenkalkulation von
Hallo zusammen,

es wurde ja bereits diskutiert wie man eine bestimmte Ausgangszahl in unterschiedlich große Teile zerlegt, in Abhängigkeit einer Teilanzahl.

Folgendes Makro teilt bspw. 10 Paletten auf 2 Gebinde-IDs auf:

Sub Zahlenteilung()
Randomize Timer

Dim Ausgangszahl As Integer
Dim Teilanzahl As Integer

Dim Zahl As Integer
Dim Sum As Integer
Dim Max As Integer
Dim z As Integer

Ausgangszahl = Cells(2, 2).Value
Teilanzahl = Cells(2, 3).Value
Sum = 0
Zahl = 0
Max = Ausgangszahl

For z = 1 To Teilanzahl - 1
Zahl = Int(Rnd * ((Max / (Teilanzahl - z)) + 1))
Sum = Sum + Zahl
Cells(1 + z, 1).Value = Zahl
If Sum = Ausgangszahl Then
Max = 0
Else
Max = Ausgangszahl - Sum
End If
Next z
If Sum = Ausgangszahl Then
Cells(1 + Teilanzahl, 1).Value = 0
Else
Cells(1 + Teilanzahl, 1).Value = Ausgangszahl - Sum
End If

End Sub

In Excel sieht das dann wie folgt aus:

Aufteilung Anzahl Paletten Anzahl GebindeID Kennung
4 10 2 1
6 10 2 1
25 3 2
25 3 2
25 3 2
80 2 3
80 2 3

Wie man an meiner Tabelle erkennen kann folgt nach der Aufteilung der 10 Palletten auf 2 Gebinde-IDs direkt die nächste Aufteilung.

Vielleicht kann mich jemand helfen und hat eine Idee wie ich das Makro anpassen kann, dass immer bei "wechselnder Kennung" das Makro erneut Ausgangszahl und Teilanzahl abfragt und ausgibt.

Vielen Dank im Voraus.
Grüße
Gianna

11 Antworten

0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Gianna,

wenn ich das richtig sehe, steht in Zelle B2 die Anzahl der zu teilenden Paletten und in Zelle C2 die Anzahl der gewünschten Gebinde. Aber wo steht denn die Kennung?

Im Moment werden nur die beiden oben genannten Zellen abgefragt. Stehen in deiner Tabelle eventuell mehrere gewünschte Aufteilungen untereinander?

Erkläre doch mal den Aufbau deiner Ausgangstabelle oder stelle eine Beispieltabelle auf einem Hoster deiner Wahl (z.B. hier ein) und poste den Link.

Gruß

M.O.
0 Punkte
Beantwortet von
Hallo M.O.

ich habe eine Beispieltabelle mal hochgeladen...da sieht man hoffentlich besser was ich meine.

http://www79.zippyshare.com/v/3BteXiFP/file.html

Das Makro trägt mir eine Aufteilung für die Kennung 1 ein und hört dann auf, da die Aufgabe 10 Paletten auf 2 Gebinde IDs zu verteilen gelöst ist.

Und ja damit hats du recht: Es stehen mehrere gewünschte Aufteilungen untereinander. Die nächste Aufteilung wäre dann 25 Paletten auf 3 Gebinde -IDs und danach 80 Paletten auf 2 Gebinde-IDs....usw. Meine Original-Tabelle umfasst über 1600 Kennungen die es aufzuteilen gilt.

Ist das Problem jetzt besser erklärt?

Vielen Dank schonmal.

Grüße
Gianna
0 Punkte
Beantwortet von
Achso...vielleicht ist folgende Info noch relevant:

Die Anzahl Paletten bzw. Anzahl Gebinde-ID sind jeweils nur pro Kennung einmal relevant.

Die Abfrage müsste dann quasi immer schauen wann eine neue Kennung anfängt und dann die Ausgangszahl und Teilanzahl erneut abfragen und die Aufteilung auslesen.

Vielen lieben Dank für die Hilfe.
Grüße
Gianna
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Gianna,

das folgende Makro gehört in ein Standard Modul deiner Arbeitsmappe:

Sub aufteilen()

Dim lngLetzte As Long
Dim lngZeile As Long
Dim lngAnzPaletten As Long
Dim lngAnzGebinde As Long
Dim lngZahl1 As Long
Dim lngZahl2 As Long
Dim lngID As Variant
Dim i As Long

'letzte Zeile in Spalte ermitteln
lngLetzte = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row

'alle Zeilen durchlaufen
For lngZeile = 2 To lngLetzte
'Prüfen, ob ID identisch ist mit eingelesener ID
If lngID <> Cells(lngZeile, 4) Then
'falls nein, Daten einlesen
lngID = Cells(lngZeile, 4) 'ID
lngAnzPaletten = Cells(lngZeile, 2) 'Anzahl Paletten
lngAnzGebinde = Cells(lngZeile, 3) 'Anzahl Gebinde
'und Aufteilung errechnen
lngZahl1 = Int(lngAnzPaletten / lngAnzGebinde) 'Ganze Zahl ermitteln
If lngAnzPaletten Mod lngAnzGebinde > 0 Then 'prüfen ob Rest vorhanden
'falls ja, dann Zahl für letztes Gebinde ermitteln
lngZahl2 = lngAnzPaletten - lngZahl1 * (lngAnzGebinde - 1)
Else
'falls nein, dann Zahl1 übernehmen
lngZahl2 = lngZahl1
End If
'Daten in Zeilen schreiben
For i = 0 To lngAnzGebinde - 2
Cells(lngZeile + i, 1) = lngZahl1
Next i
Cells(lngZeile + lngAnzGebinde - 1, 1) = lngZahl2
End If
Next lngZeile

End Sub


Probier mal, ob das Makro so arbeitet, wie du willst.

Gruß

M.O.
0 Punkte
Beantwortet von
Hallo M.O.,

wow vielen herzlichen Dank für deine Unterstützung. Ich habe das Makro in ein Standard-Modul gepackt und es laufen lassen.

Einzig die Tatsache, dass es jetzt anfangs 1,1,1,1,1... oder sogar 0,0,0,... .vergibt und bei der letzten Kennung den REST aufschlägt, macht es genau das was es soll.

http://www75.zippyshare.com/v/oBiS6ngO/file.html

Ich weiß nicht, ob die Möglichkeit besteht die Verteilung etwas "mehr zu streuen"?

Aber schonmal vielen Dank!

Ich versuche jetzt erstmal den Code nachzuvollziehen...

LIebe Grüße
Gianna
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Gianna,

ich schaue mir das noch einmal an (ich habe da schon eine Idee). In einigen Zeilen deiner 2. Datei steht #NV bei der Anzahl der Paletten. Hat das was zu bedeuten, oder ist das nur ein Kopierfehler?

Aber eine Nullaufteilung lässt sich nicht verhindern, wenn die Anzahl der Gebinde größer als die Anzahl der aufzuteilenden Paletten ist (oder gibt es auch halbe Paletten?).

Gruß

M.O.
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Gianna,

hier die verbesserte und schnellere Version:

Sub aufteilen_neu()
Dim lngLetzte As Long
Dim arrDaten As Variant
Dim arrAufteilung As Variant
Dim lngZeile As Long
Dim lngSumme As Long
Dim lngPaletten As Long
Dim lngGebinde As Long
Dim varKennung As Variant
Dim p As Long
Dim g As Long

'letzte Zeile in Spalte ermitteln
lngLetzte = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row

'Array für Daten redimensionren
ReDim arrDaten(lngLetze, 4)
'Daten der Spalten B bis E ab Zeile 2 in Array einlesen
arrDaten = ActiveSheet.Range(Cells(2, 2), Cells(lngLetzte, 5))

'alle Daten durchlaufen und Aufteilung generieren
For lngZeile = 1 To UBound(arrDaten, 1)
'Prüfen, ob Anzahl Paletten eine Zahl ist
If IsNumeric(arrDaten(lngZeile, 1)) = True Then
'Prüfen, ob neue Kennung
If varKennung <> arrDaten(lngZeile, 4) Then
'falls ja, dann
varKennung = arrDaten(lngZeile, 4) 'neue Kennung in Variable schreiben
lngPaletten = arrDaten(lngZeile, 1) 'Anzahl der Paletten in Varible schreiben
lngGebinde = arrDaten(lngZeile, 2) 'Anzahl der Gebinde in Variable schreiben
'Array für Aufteilung redimensionieren = Anzahl der Gebinde
ReDim arrAufteilung(lngGebinde)
'nun Paletten aufteilen
lngSumme = 0 'Variable für Kontrollsumme auf Null setzen
For p = 1 To lngPaletten
For g = 1 To lngGebinde
If lngSumme < lngPaletten Then
arrAufteilung(g) = arrAufteilung(g) + 1
lngSumme = lngSumme + 1
End If
Next g
Next p
'Aufteilung in Datei schreiben
For g = 1 To lngGebinde
If arrAufteilung(g) = 0 Then
ActiveSheet.Cells(lngZeile + g, 1) = 0 'falls Feld in Aufteilung leer, Null in Zelle schreiben
Else
ActiveSheet.Cells(lngZeile + g, 1) = arrAufteilung(g) 'ermittelte Aufteilung in Zelle schreiben
End If
Next g
End If
Else
ActiveSheet.Cells(lngZeile + 1, 1) = "Anzahl Paletten ist keine Zahl"
End If
Next lngZeile
End Sub


Schau mal, ob die Aufteilung nun besser ist.

Gruß

M.O.
0 Punkte
Beantwortet von
Hallo M.O.,

vielen Dank vorweg für deine große Hilfe.

Leider rechnet das Makro jetzt was komisches aus. Entweder die aufgeteilte Menge ist jetzt doppelt so groß wie die Anzahl der Gebinde-IDs oder gleich der Anzahl der Gebinde-IDs.

Ein Bezug zu der Palettenanzahl ist jetzt völlig weg. Ich bin aber gerade am rumprobieren und hoffe den Fehler zu finden.

Im Anhang das Ergebnis wenn das Makro durchläuft:

www84.zippyshare.com/v/hzSAwqrE/file.html

Falls Dir ad hoc einfällt was da gerade schief geht bzw. ich einen Fehler mache würde ich mich über eine Antwort sehr freuen.

Beste Grüße
Gianna
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Gianna,

bei deiner in Antwort 5 geposteten Datei war die Kennung in Spalte, jetzt ist sie in Spalte D. Deshalb funktioniert das Makro nicht mehr korrekt.

Hier das angepasste Makro zu deiner neuen Datei:

Sub aufteilen_neu()

Dim lngLetzte As Long
Dim arrDaten As Variant
Dim arrAufteilung As Variant
Dim lngZeile As Long
Dim lngSumme As Long
Dim lngPaletten As Long
Dim lngGebinde As Long
Dim varKennung As Variant
Dim p As Long
Dim g As Long

'letzte Zeile in Spalte ermitteln
lngLetzte = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row

'Array für Daten redimensionren
ReDim arrDaten(lngLetze, 4)
'Daten der Spalten B bis E ab Zeile 2 in Array einlesen
arrDaten = ActiveSheet.Range(Cells(2, 2), Cells(lngLetzte, 5))

'alle Daten durchlaufen und Aufteilung generieren
For lngZeile = 1 To UBound(arrDaten, 1)
'Prüfen, ob Anzahl Paletten eine Zahl ist
If IsNumeric(arrDaten(lngZeile, 1)) = True Then
'Prüfen, ob neue Kennung
If varKennung <> arrDaten(lngZeile, 3) Then
'falls ja, dann
varKennung = arrDaten(lngZeile, 3) 'neue Kennung in Variable schreiben
lngPaletten = arrDaten(lngZeile, 1) 'Anzahl der Paletten in Varible schreiben
lngGebinde = arrDaten(lngZeile, 2) 'Anzahl der Gebinde in Variable schreiben
'Array für Aufteilung redimensionieren = Anzahl der Gebinde
ReDim arrAufteilung(lngGebinde)
'nun Paletten aufteilen
lngSumme = 0 'Variable für Kontrollsumme auf Null setzen
For p = 1 To lngPaletten
For g = 1 To lngGebinde
If lngSumme < lngPaletten Then
arrAufteilung(g) = arrAufteilung(g) + 1
lngSumme = lngSumme + 1
End If
Next g
Next p

'Aufteilung in Datei schreiben
For g = 1 To lngGebinde
If arrAufteilung(g) = 0 Then
ActiveSheet.Cells(lngZeile + g, 1) = 0 'falls Feld in Aufteilung leer, Null in Zelle schreiben
Else
ActiveSheet.Cells(lngZeile + g, 1) = arrAufteilung(g) 'ermittelte Aufteilung in Zelle schreiben
End If
Next g
End If
Else
ActiveSheet.Cells(lngZeile + 1, 1) = "Anzahl Paletten ist keine Zahl"
End If
Next lngZeile

End Sub

Gruß
M.O.
0 Punkte
Beantwortet von
Hallo M.O.,

aha da lag der Fehler.

Vielen Dank. Das Makro macht jetzt genau das was ich brauche und ich kann es in meine Simulation einbinden.

Vielen lieben Dank für die Hilfe.

Beste Grüße
Gianna
...