Hallo und einen schönen Abend,
ich versuche gerade den unten stehenden Code von Atilla ...
Code:
Sub ordne_um_mit_verbundenen_Zellen2()
Dim i As Long, j As Long, k As Long, n as Long
Dim lngZ As Long
Dim lngAnzahl As Long, lngEinheiten As Long
Dim strgAddressen As String
Dim varA, varZiel
With Sheets("Tabelle1")
lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
varA = .Range("A6:K" & lngZ)
lngEinheiten = Application.Sum(.Range("D6:D" & lngZ))
If lngZ - 5 > Application.Count(.Range("D6:D" & lngZ)) Then
lngEinheiten = lngEinheiten + lngZ - 5 - Application.Count(.Range("D6:D" & lngZ))
End If
End With
With Sheets("Tabelle3")
.Columns("D").MergeCells = False
lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Range("A2").Resize(lngZ - 1, UBound(varA, 2)).ClearContents
varZiel = .Range("A2").Resize(lngEinheiten, UBound(varA, 2))
For i = LBound(varA) To UBound(varA)
If varA(i, 4) > 1 Then strgAddressen = strgAddressen & ", " & .Range(.Cells(k + 2, 4), .Cells(k + varA(i, 4) + 1, 4)).Address
varZiel(k + 1, 4) = varA(i, 4)
If varA(i, 4) = "" Then varA(i, 4) = 1
For j = 1 To varA(i, 4)
For n = 1 To UBound(varA, 2)
varZiel(k + j, n) = varA(i, n)
If n = 3 Then n = n + 1
Next n
Next j
k = k + j - 1
Next i
strgAddressen = Mid(strgAddressen, 3)
.Range("A2").Resize(lngEinheiten, UBound(varA, 2)) = varZiel
.Range(strgAddressen).MergeCells = True
End With
End Sub
...auf eine andere Position zu verändern, bekomme jedoch immer wieder Fehlermeldung. Ich vermute, dass mir für etwas grundlegendes hier noch das Verständnis fehlt.
Die gesuchten Werte in "Tabelle1" stehen nun alle ab ("B5") und abwärts und sollen in "Tabelle3" ebenfalls ab ("B5") eingetragen werden.
Mein unten stehender Versuch ist bislang leider gescheitert...
Code:
Sub ordne_um_mit_verbundenen_Zellen2()
Dim i As Long, j As Long, k As Long, n as Long
Dim lngZ As Long
Dim lngAnzahl As Long, lngEinheiten As Long
Dim strgAddressen As String
Dim varA, varZiel
With Sheets("Tabelle1")
lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
varA = .Range("B5:K" & lngZ)
lngEinheiten = Application.Sum(.Range("E5:E" & lngZ))
If lngZ - 5 > Application.Count(.Range("E5:E" & lngZ)) Then
lngEinheiten = lngEinheiten + lngZ - 5 - Application.Count(.Range("E5:E" & lngZ))
End If
End With
With Sheets("Tabelle3")
.Columns("E").MergeCells = False
lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Range("B5").Resize(lngZ - 1, UBound(varA, 2)).ClearContents
varZiel = .Range("B5").Resize(lngEinheiten, UBound(varA, 2))
For i = LBound(varA) To UBound(varA)
If varA(i, 4) > 1 Then strgAddressen = strgAddressen & ", " & .Range(.Cells(k + 2, 4), .Cells(k + varA(i, 4) + 1, 4)).Address
varZiel(k + 1, 4) = varA(i, 4)
If varA(i, 4) = "" Then varA(i, 4) = 1
For j = 1 To varA(i, 4)
For n = 1 To UBound(varA, 2)
varZiel(k + j, n) = varA(i, n)
If n = 3 Then n = n + 1
Next n
Next j
k = k + j - 1
Next i
strgAddressen = Mid(strgAddressen, 3)
.Range("B5").Resize(lngEinheiten, UBound(varA, 2)) = varZiel
.Range(strgAddressen).MergeCells = True
End With
End Sub
Könnte mir jemand sagen, wo ich falsch an die Versetzung herangegangen bin?
Vielen Dank und einen schönen Abend
Gruß Bookshelf3011