Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Zellen Finden & löschen dann finden und kopieren

Zellen Finden & löschen dann finden und kopieren
13.08.2016 18:16:17
Andreas
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 

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

Betreff
Datum
Anwender
Anzeige
AW: Zellen Finden & löschen dann finden und kopieren
14.08.2016 00:44:15
Werner

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 

AW: Zellen Finden & löschen dann finden und kopieren
14.08.2016 00:55:59
Werner
Hallo Andreas,
meine erste Antwort habe ich versehentlich gesendet, bitte ignorieren, da fehlte was im Code noch.
Versuch das mal hier. Kann aber nicht garantieren dass es läuft, konnte nicht testen, nur Tablet zur Verfügung. Kann auch nicht garantieren, dass keine Schreibfehler im Code vorhanden sind.
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 
Gruß Werner
Anzeige
AW: Zellen Finden&löschen dann finden und kopieren
14.08.2016 12:41:42
Andreas
Hallo Werner,
vielen Dank für deine Hilfe. Es klappt nun. Ich habe nur eine kleine Änderung vorgenommen.
Der vollständige und funktionierende Code lautet nun wie folgt.
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 

Anzeige
AW: Gerne u. Danke für die Rückmeldung. o.w.T
14.08.2016 15:26:57
Werner

305 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige