Zellen Finden & löschen dann finden und kopieren

Hallo Zusammen,
ich sitze nun schon seit einigen Tagen an einer VBA Lösung um in einer Tabelle die 3 Spalten hat zunächst einmal in Spalte B nach einem Begriff zu suchen, dann diesen und die folgenden 5 Zeilen zu löschen, nachdem das erledigt ist will ich die Liste noch einmal durchlaufen wieder einen Begriff suchen, dann diesen und die Zelle A in der selben Zeile sowie die Zelle C derselben Zeile kopieren + die folgenden 3 Zeilen Zelle A,B, und C bei F1 angefangen wieder einfügen. Die Begriffe kommen immer mehrmals vor, so dass ich sie jeweils unten anfügen will.
Was ich nicht verstehe ist, wie ich die benachbarten Zellen von B ausgesehen (also -1 und +1) markiere + die folgenden 3 Zeilen A,B,C um sie dann bei F einzufügen.
Hier ist der Code den ich habe:

Sub auto_loeschen_und_kopieren()
Dim suche1 As Range
Dim suche2 As Range
Dim zaehler1 As Long
Dim zaehler2 As Long
Dim Suchwert1 As Variant
Dim Suchwert2 As Variant
Suchwert1 = "Kaltwasserdruck"
Suchwert2 = "Saugseite"
Application.ScreenUpdating = True
For zaehler1 = 2 To Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
zeile = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
Set suche1 = Sheets(1).Range("B" & zaehler1 & ":B" & zeile).Find(Suchwert1, LookIn:= _
xlValues)
If Not suche1 Is Nothing Then
zaehler1 = suche1.Row - 2
If zaehler1

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub auto_loeschen_und_kopieren() Dim loLetzte As Long Dim suche1 As Range Dim suche2 As Range Dim Suchwert1 As String Dim Suchwert2 As String Suchwert1 = "Kaltwasserdruck" Suchwert2 = "Saugseite" Do Set suche1 = Sheets(1).Columns(2).Find(Suchwert1) If Not suche1 Is Nothing Then suche1.Resize(4, 0).EntireRow.Delete Loop Until suche1 Is Nothing Do loLetzte = Sheets(1).Cells(Rows.Count, 6).End(xlUp).Row + 1 If loLetzte

Sub auto_loeschen_und_kopieren() Dim loLetzte As Long Dim suche1 As Range Dim suche2 As Range Dim Suchwert1 As String Dim Suchwert2 As String Suchwert1 = "Kaltwasserdruck" Suchwert2 = "Saugseite" Do Set suche1 = Sheets(1).Columns(2).Find(Suchwert1) If Not suche1 Is Nothing Then suche1.Resize(5, 0).EntireRow.Delete Loop Until suche1 Is Nothing Do loLetzte = Sheets(1).Cells(Rows.Count, 6).End(xlUp).Row + 1 If loLetzte

Sub finden_loeschen_kopieren() Dim loLetzte As Long Dim suche1 As Range Dim suche2 As Range Dim suche3 As Range Dim Suchwert1 As String Dim Suchwert2 As String Suchwert1 = "Kaltwasserdruck" Suchwert2 = "Saugseite" Application.ScreenUpdating = False Do Set suche1 = Sheets(1).Columns(2).Find(Suchwert1) If Not suche1 Is Nothing Then Sheets(1).Range(suche1.Row & ":" & suche1.Row + 5).Delete _ Shift:=xlUp Loop Until suche1 Is Nothing Do loLetzte = Sheets(1).Cells(Rows.Count, 6).End(xlUp).Row + 1 If loLetzte

Beliebteste Forumthreads (12 Monate)

Zellen Finden & löschen dann finden und kopieren

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellen Finden & löschen dann finden und kopieren

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread