Zelleinträge suchen und Zellen verschieben

[sunny01]

Hallo,

wer kennt eine Möglichkeit, per Makro z.B. in Spalte D nach dem Eintrag "Test" zu suchen und wenn dieser Eintrag gefunden wurde sollten die Inhalte der Zellen in Spalte D (=Test) bis Spalte F ausgeschnitten werden und in derselben Zeile von Spalte A bis C wieder eingefügt werden. Ich habe bereits einen Code zur Suche nach zwei Einträgen ("Test" und "Test01", siehe unten), dieser benötigt jedoch bei ca. 10000 vorhandenen Zeilen extrem lange und ist dadurch nicht brauchbar.

Code:

Sub Zellen_verschieben()

   Dim i As Long
   With Worksheets("Tabelle1")
   
       For i = 1 To 64000
           If Cells(i, 4) = "Test" Then
               Worksheets("Tabelle1").Range(Cells(i, 4), Cells(i, 6)).Select
               Selection.Cut Destination:=Range(Cells(i, 1), Cells(i, 3))
               i = i + 2
           End If
       Next i
       For i = 1 To 64000
           If Cells(i, 4) = "Test01" Then
               Worksheets("Tabelle1").Range(Cells(i, 4), Cells(i, 6)).Select
               Selection.Cut Destination:=Range(Cells(i, 1), Cells(i, 3))
               i = i + 2
           End If
       Next i
   End With

End Sub

[Rabe]

Hi,

etwas schneller geht es, wenn Du nach der With-Zeile dies hinsetzt:
loLetzte = .Cells(Rows.Count, 4).End(xlUp).Row ' letzte belegte Zelle in Spalte D (4)

und dann anstelle der 64000 das loLetzte einsetzt.

Am Anfang noch die Variable dimensionieren:
Dim loLetzte As Long

[schauan]

Hallöchen,

wenn in den Zellen nur Werte stehen und keine Formeln, würde es mit einem Array deutlich schneller gehen.
Lese den Bereich in ein Array ein:

Dim arrZellen, iCnt As Long
...

arrzellen=.Range("A1:F" & .Cells(Rows.Count, 4).End(xlUp).Row).Value 'Letzte Zelle anhand Spalte 4=D
'Schleife ueber alle Eintraege
For iCnt=1 To ubound(arrzellen,1)
If arrzellen(icnt,4) = "Test" Then 'Deine Prüfung
'Daten ersetzen und Quelle leeren
arrzellen(icnt,1)=arrzellen(icnt,4)
arrzellen(icnt,4)=""
arrzellen(icnt,2)=arrzellen(icnt,5)
arrzellen(icnt,5)=""
arrzellen(icnt,3)=arrzellen(icnt,6)
arrzellen(icnt,3)=""
End If
Next
'Daten zurueckschreiben
.Range("A1:F" & .Cells(Rows.Count, 4).End(xlUp).Row).Value = arrzellen 'Letzte Zelle anhand Spalte 4=D