Ging mir ein wenig auf den Zeiger. ;)
Option Explicit
Public Sub Test()
Dim rngData As Excel.Range
With Worksheets("Tabelle1")
' [A] [B]
'1: Art ¦ Menge
' -----+------
'2: 1 | 34
'3: 2 | 7
'4: 3 | 7
'5: 4 | 18
With .Range("B2") '< erste "Daten"-Zelle in Spalte Menge
'Bereich mit Daten in Spalte B ab Zeile 2 ermitteln
Set rngData = .Worksheet.Range(.Cells(1), .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp))
If rngData.Row < .Row Then
Call MsgBox("Keine Daten zum Verarbeiten vorhanden!", vbExclamation)
Exit Sub
End If
End With
End With
Dim retVal As Variant
Dim k_max As Long 'maximale Menge k
Dim k As Long 'Menge k
Dim n As Long 'Anzahl (Zeilen)
Do
retVal = Application.InputBox("Maximal zulässige Menge (z.B. 5, 12 oder 42):", "Maximal Menge eingeben", 21, Type:=1)
If VarType(retVal) = vbBoolean Then
Exit Sub
ElseIf 0 >= retVal Or retVal > &H7FFFFFFF Then
Call MsgBox("Nur Zahlen zwischen 1 und 2.147.483.647 erlaubt.", vbExclamation)
ElseIf (retVal \ 1) <> retVal Then
Call MsgBox("Nur ganze Zahlen erlaubt!", vbExclamation)
Else
Exit Do
End If
Loop
k_max = retVal
Dim i As Long
'von unten nach oben (!)
For i = rngData.Cells.Count To 1 Step -1
With rngData.Cells(i)
k = .Value 'Menge k
n = (k \ k_max + 1) 'Anzahl (Zeilen)
If n > 1 Then
'neue Zeilen einfügen
Call .Offset(1).Resize(n - 1).EntireRow.Insert(xlShiftDown)
'Spalte [Art]: übertrage den Wert in neue Zeilen
.Resize(n).Offset(0, -1) = .Offset(0, -1)
'Spalte [Menge]: setze neue Werte
.Resize(n).Value = k \ n
'Spalte [Menge]: ggf. Rest aufteilen
For k = 1 To (k Mod n)
.Offset(k - 1).Value = .Offset(k - 1).Value + 1
Next
End If
End With
Next
Call MsgBox("Fertig.", vbInformation)
End Sub
|