Lösung
07.07.2005 19:24:12
Reinhard
Hallo Andreas,
du hast noch in E14 usw verbundene zellen, du erkennst sie leicht nach Durchlauf des makros.
Gruß
Reinhard
Sub tt()
anz = Int(Worksheets("Mengenmeldung NHA").UsedRange.Rows.Count / 28)
ReDim block(anz, 2)
For n = 3 To anz * 28 Step 28
block(Int(n / 28 + 1), 1) = Mid(Worksheets("Mengenmeldung NHA").Cells(n, 1), 3)
block(Int(n / 28 + 1), 2) = n
Next n
Worksheets.Add 'mir ist grad entfallen wie man ein Array sortiert *g, deshalb so
ActiveSheet.Name = "kurz"
With Worksheets("kurz")
For n = 1 To anz
.Cells(n, 1) = n
.Cells(n, 2) = block(n, 1)
.Cells(n, 3) = block(n, 2)
'MsgBox block(n)
Next n
.Range("A1:C" & anz).Sort Key1:=.Range("B1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
With Worksheets("Mengenmeldung NHA")
.Cells.Copy
Worksheets.Add
ActiveSheet.Paste
For n = 1 To anz
For nn = 0 To 27
'MsgBox 3 + (n - 1) * 28 + nn
'MsgBox Worksheets("kurz").Cells(n, 3) + nn
.Rows(Worksheets("kurz").Cells(n, 3) + nn).Copy Destination:=ActiveSheet.Rows(3 + (n - 1) * 28 + nn)
Next nn
Next n
Application.DisplayAlerts = False
.Delete
End With
ActiveSheet.Name = "Mengenmeldung NHA"
Worksheets("kurz").Delete
Application.DisplayAlerts = True
End Sub