AW: Zahlen 1-100 gleichmäßig auf Gruppen verteilen
26.10.2016 11:02:28
Sev
Hier das Makro:
Sub verteilen_neu()
Dim BereichVerteilung As Range
Dim Verteilung
Dim VerteilungIst
Dim VerteilungSoll
Dim VertGes As Integer
Dim AnzahlVerteilt As Integer
Dim AnzahlAkten As Integer
Dim i As Integer
Dim Obergrenze As Integer
Dim Untergrenze As Integer
Set BereichVerteilung = Range("A2:F2") 'Der Bereich in dem der Verteilungsschlüssel steht.
'In der nächsten Reihe wird die Anzahl der zu verteilenden Akten eingetragen
BereichVerteilung.Offset(3).Resize(500, BereichVerteilung.Columns.Count).ClearContents
Verteilung = BereichVerteilung
Verteilung = WorksheetFunction.Transpose(Verteilung)
Verteilung = WorksheetFunction.Transpose(Verteilung)
VertGes = WorksheetFunction.Sum(BereichVerteilung)
For i = LBound(Verteilung) To UBound(Verteilung)
Verteilung(i) = Verteilung(i) / VertGes
Next
VerteilungIst = BereichVerteilung.Offset(1, 0)
VerteilungIst = WorksheetFunction.Transpose(VerteilungIst)
VerteilungIst = WorksheetFunction.Transpose(VerteilungIst)
VerteilungSoll = Verteilung
Untergrenze = InputBox("verteilen von: ")
Obergrenze = InputBox("verteilen bis: ")
AnzahlAkten = Obergrenze - Untergrenze + 1
AnzahlVerteilt = WorksheetFunction.Sum(BereichVerteilung.Offset(1, 0))
VertGes = AnzahlAkten + AnzahlVerteilt
For i = LBound(Verteilung) To UBound(Verteilung)
VerteilungSoll(i) = Verteilung(i) * VertGes
Verteilung(i) = Verteilung(i) * AnzahlAkten
Next
Dim sz As String
Dim zz As Integer
Dim zuVerteilen As Integer
Dim letzteZeile As Long
Dim PlatzGefunden As Boolean
sz = ""
zuVerteilen = AnzahlAkten
Do
Do
zz = Int((Obergrenze - Untergrenze + 1) * Rnd + Untergrenze)
Loop While InStr(1, sz, "#" & zz & "#") > 0
sz = sz & "#" & zz & "#"
i = 1
PlatzGefunden = False
Do
If Verteilung(i) >= 1 Then 'so lang eine normale Verteilung möglich ist wird normal _
verteilt
letzteZeile = BereichVerteilung.Cells(i).Offset(500).End(xlUp).Row + 1
If letzteZeile UBound(Verteilung) And Not PlatzGefunden Then 'ist eine Verteilung nicht mö _
glich wird der erste mit der größten differenz zum soll belastet.
Dim mI As Integer, Max As Double
Max = VerteilungSoll(1) - VerteilungIst(1)
mI = 1
For i = 2 To UBound(VerteilungSoll)
If Max 0
BereichVerteilung.Offset(1) = VerteilungIst
End Sub