Automatisiertes Einfügen von Zeilen anhand von Faktoren

[Bookshelf3011]

Hallo atilla,

jetzt funktioniert es. Wunderbar. Vielen, vielen Dank.

Warum aber jetzt und gestern nicht, kann ich leider auch nicht sagen. Aber Hauptsache es klappt.  :19:

Nochmals danke.

Einen schönen Abend

Gruß

Bookshelf3011

[Bookshelf3011]

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

[atilla]

Hallo,

ohne eine passende Beispieldatei wird da wohl keiner sich ran trauen, auch ich nicht.

[Bookshelf3011]

Hallo Atilla,

die passende Testdatei habe ich mit angehängt.

Gruß

Bookshelf3011

[atilla]

Hallo,

bei dem Code blick ich ja selber nicht richtig durch, Andere hätten da wahrscheinlich noch mehr Mühe.

Wenn ich Dich und meine Code richtig verstanden habe   :19: , dann müsste folgendes gehen:

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, 2).End(xlUp).Row
  varA = .Range("B5:K" & lngZ)
  lngEinheiten = Application.Sum(.Range("J5:J" & lngZ))
  If lngZ - 5 > Application.Count(.Range("J5:J" & lngZ)) Then
    lngEinheiten = lngEinheiten + lngZ - 4- Application.Count(.Range("J5:J" & lngZ))
  End If
End With

With Sheets("Tabelle3")
  .Columns("J").MergeCells = False
  lngZ = .Cells(.Rows.Count, 2).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, 9) > 1 Then strgAddressen = strgAddressen & ", " & .Range(.Cells(k + 5, 10), .Cells(k + varA(i, 9) + 4, 10)).Address
    varZiel(k + 1, 9) = varA(i, 9)
    If varA(i, 9) = "" Then varA(i, 9) = 1
    For j = 1 To varA(i, 9)
      For n = 1 To UBound(varA, 2)
        varZiel(k + j, n) = varA(i, n)
        If n = 8 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

[Bookshelf3011]

Hallo atilla,

genau das meinte ich..der Code funktioniert einwandfrei.

Vielen Dank und noch ein frohes Osterfest.

Gruß

Bookshelf3011