Insert Shift Down Funktion fehlerhaft im Loop

[zapfer791]

Hallo zusammen,

ich habe ein Makro erstellt, bei dem in Tabellenblatt 1 kriterien gesucht werden und wenn diese zutreffen, die entsprechenden Daten in Tabellenblatt 2 und 3 kopiert und eingefügt werden sollen. Der Loop läuft bei Tabellenblatt 2 gut, hört aber bei Tabellenblatt 3 einfach auf und highlightet im VBA die entsprechende Zeile mit dem Hinweis auf push-Zellen die scheinbar im Weg sind.
Bitte um Hilfe wie ich die Formel entsprechend anpassen kann. Die eingefügten Daten sollen jeweils oben in der Tabelle via insert Befehl eingefügt werden und nicht ans Ende der Tabelle. Kleine Besonderheit bei Tabellenblatt 3 ist, dass ich hier nur die Werte übernehmen will, nicht die Formatierung. Hier mal der Ausschnitt mit der gehighlighteten Zeile:

Sub DatenÜbertragen1()

Dim lngZeile As Long
Dim rngZelleX As Range
Dim test As Boolean

test = True
lngZeile = 5
Do While test
test = False

        Sheets("Tabellenblatt 1").Select
        Set rngZelleX = Sheets("Tabellenblatt 1").Columns.Find(What:="J", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns,   SearchDirection:=xlNext, MatchCase:=True)
        If Not rngZelleX Is Nothing Then
        test = True
        lngZeile = lngZeile + 1
        rngZelleX.EntireRow.Select
        rngZelleX.EntireRow.Copy
        Sheets("Tabellenblatt 2").Cells(lngZeile, 1).Insert Shift:=xlDown
        rngZelleX.EntireRow.Copy
        Sheets("Tabellenblatt 3").Cells(lngZeile, 1).Insert Shift:=xlDown
        rngZelleX.EntireRow.Copy
        Sheets("Tabellenblatt 3").Cells(lngZeile, 1).PasteSpecial xlPasteValues
        rngZelleX.EntireRow.Delete Shift:=xlUp
       
    End If

    Loop

...
Vielen Dank im Voraus!

[Lutz Fricke]

Hallo zapfer791,

was genau besagt die Fehlermeldung?
Ist der Aufbau von Tabelle 2 und 3 unterschiedlich? Funktioniert das manuelle Einfügen einer Zeile?

Mit einer Beispieldatei wär's einfacher...

Gruß,
Lutz

[Gast 123]

Hallo

man frage im Internet was "push Zellen" sind und versteht sofrt:   Überlauf über das Blattende, d.h., Do Loop Todesschleife mit Überlauf!
Dann stimmt die Logik im Loop Code nicht wann das Kopierende erreicht wurde!

Probier bitte mal den von mir geänderten Code aus, den musst du aber bitte noch anpassen!!
Du suchst den Text "J" in Columns, ohne die Spalte anzugeben. Bitte die Spalten Nummer oder als Text eingeben, bitte auch die Spalte bei After:=Cells() mit angeben!!  Ich verwende den Direction Befehl xlPrevious, d.h., RÜCKWÄRTS suchen und löschen!  Das hat den Vorteil das die Daten 1:1 kopiert werden, sonst drehst du die Reihenfolge der Daten um!

Die Daten werden ab Zeile 5 bzw. 6 nach unten verschoben und als ganze Zeileoder nur als Werte eingefügt. Würde mich freuen wenn alles einwandfrei klappt.  Ich bin auf deine Antwort gespannt, besonders auch wegen dem Rückwärts suchen.

mfg Gast 123

Code:

Sub DatenÜbertragen1()
Dim rngZelleX As Range
Dim lngZeile As Long, n As Long
lngZeile = 5

With Sheets("Tabellenblatt 1")
     Do  '** Do mit xlPrevious für 1:1 in Tabelle 2+3 einfügen!!
     Set rngZelleX = .Columns(1).Find(What:="J", After:=Cells(Rows.Count, 1), LookIn:=xlFormulas, _
         LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=True)
        If rngZelleX Is Nothing Then Exit Do
        lngZeile = lngZeile + 1:  n = n + 1
        Sheets("Tabellenblatt 3").Rows(3).Insert Shift:=xlDown
        rngZelleX.EntireRow.Copy
        Sheets("Tabellenblatt 2").Rows(3).Insert Shift:=xlDown
        rngZelleX.EntireRow.Copy
        Sheets("Tabellenblatt 3").Rows(3).PasteSpecial xlPasteValues
        rngZelleX.EntireRow.Delete Shift:=xlUp
    Loop

    MsgBox n & "  Daten kopiert"
End With
End Sub