VBA:find schleife

Hallo Nepumuk, Björn, Rainer, und all Ihr Excel-Spezl's,
ich habe folgendes Problem an dem ich seit Tagen schon "herumschustere".
Aus dem Archiv habe ich schon viele Lösungen gefunden, dennoch komme ich
nicht weiter.
Folgende Situation:
- 3 Tabellenblätter:
    => "FB-Übersicht CR" - diese ist sozusagen der Master, der immer
aktuell sein muss
    => "gelöscht" - hier sind die Suchbegriffe/Artikel-Nr. enthalten, die
aus dem Master gelöscht werden sollen
           = temporäres Blatt, was wöchentlich mit den
changes/deletions/new SKUs aktualisiert wird
    => "Gelöschte AAs" - diese soll zum Review dienen und alle aus dem
Master gelöschten Artikel-Nr mit dem Lösch-Datum enthalten
Was ich nun brauche:
In Tabelle "gelöscht" stehen immer unterschiedliche Artikel-Nr. in Spalte
A. Diese sollen im Master
= "FB-Übersicht CR" in der Spalte A gefunden werden. Sobald dort gefunden,
soll die gesamte Zeile kopiert, in Tabelle "gelöschte AAs" übertragen
werden und aus dem Master gelöscht werden. Zusätzlich
soll in Tabelle "gelöschte AAs" in Spalte F das Datum der Ausführung des
Makros als value eingetragen werden. Ihr werdet sehen, dass im code noch
seltsame Versuche enthalten sind, nur die range der Artikel-Nr.
einzugrenzen im Blatt "gelöscht" & "gelöschte AAs". Keine Ahnung ob ich die
überhaupt brauche ...
Ich habe den nachfolgenden Code aus verschiedenen Archiv-Beiträgen
zusammengestellt, aber _
leider weiss ich keinen Rat mehr und bitte Euch um Hilfe.


Sub test()
    Dim sku, nextsku, lsku As Variant
    Dim ersteadresse, letzteadresse As String
   Dim firstaddress As String
    x = Worksheets("gelöschte aas").UsedRange.Rows.Count
    y = Application.WorksheetFunction.VLookup(Worksheets("gelöscht").Range
("A1:A10"), Sheets("   _
FB-Übersicht CR").Range("A:A"), 1, False)
    With Sheets("FB-Übersicht CR").Columns(1)
    Set sku = .Find(what:=Sheets("Gelöscht").Cells(1, 1), LookIn:=xlValues)
        If Not sku Is Nothing Then
            ersteadresse = AA.Address
            lsku = Sheets("Gelöscht").Range("A:a").SpecialCells
(xlLastCell).Address
        Do
            Sheets("FB-Übersicht CR").Rows(sku.Row).EntireRow.Copy
Destination:=Sheets("Gelö _
schte AAs"). _
            Cells(x + 1, 1).EntireRow
        Set nextsku = .FindNext(sku)
        Loop While Not AA Is Nothing And ersteadresse  AA.Address
        End If
    End With
'    Application.ScreenUpdating = True
End Sub

Ich bin der totale VBA-Anfänger und habe sicherlich im code oben einiges
durcheinander gebracht, falsch gemacht, etc. denn mir wird immer nur der 1.
gefundene kopiert - die Suche wird nicht fortgesetzt ...? Das Löschen habe
ich nicht drin im code, weil ich erst testen wollte ... aber soweit komm
ich ja schon gar nicht ...
Ich bedanke mich schon mal für Eure Mühe & Verständnis für den Anfänger!
VG Dani

Hallo
Könnte man so machen:
Hab das Eingefügte fett markiert mit einem '* dahinter

Option Explicit
Sub geloeschte_entfernen()
Dim sku As Range
Dim bolDelete As Boolean
Dim wksCR As Worksheet, wksGeloescht As Worksheet, wksAAs As Worksheet
Dim LastRowAAs As Long, Rowgeloescht As Long
Dim Grund$ '*
Set wksAAs = Worksheets("gelöschte aas")
Set wksCR = Worksheets("FB-Übersicht CR")
Set wksGeloescht = Worksheets("Gelöscht")
Application.ScreenUpdating = False
With wksAAs
LastRowAAs = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
With wksGeloescht
Rowgeloescht = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
For Rowgeloescht = 1 To Rowgeloescht
If wksGeloescht.Cells(Rowgeloescht, 1)  "" Then
 Grund = wksGeloescht.Cells(Rowgeloescht, 12).Value '*
With wksCR.Columns(1)
Set sku = .Find(what:=wksGeloescht.Cells(Rowgeloescht, 1), LookIn:=xlValues, _
lookat:=xlWhole)
If Not sku Is Nothing Then
Do
LastRowAAs = LastRowAAs + 1
sku.EntireRow.Copy
wksAAs.Rows(LastRowAAs).PasteSpecial Paste:=xlPasteFormats
wksAAs.Rows(LastRowAAs).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
wksAAs.Cells(LastRowAAs, 6).Value = Date
wksAAs.Cells(LastRowAAs, 7).Value = Grund
sku.EntireRow.Clear
bolDelete = True
Set sku = .FindNext(after:=sku)
Loop Until sku Is Nothing
End If
End With
End If
Next Rowgeloescht
With wksCR
.Activate
If bolDelete = True Then
With .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End If
End With
Application.ScreenUpdating = True
End Sub

https://www.herber.de/bbs/user/80582.xls
Gruß Matthias

Forumthread: VBA:find schleife

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

VBA: Die .Find-Funktion für effektives Suchen und Löschen in Excel

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)