In Spalte "M" Suchen &gefundene Zellen kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Stefan!
Kopiere diesen Code in das Modul der "Tabelle2".
(Rechtsklick auf Tabellenregister &gt Code anzeigen &gt in das Codefenster eintragen)
Bei einer änderung der Zelle "A1" in "Tabelle2" wird das Makro ausgeführt!
Wenn du das Makro lieber Manuell über einen Button starten willst,
dann einfach den Code (ohne erste und letzte Zeile, in das "Click" - Ereignis
des Buttons kopieren!

' **************************************************************
' Modul: Tabelle2 Typ = Element der Mappe(Sheet, Workbook, ...)
' **************************************************************
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim rng As Range
Dim sFirst As String
Dim lngC As Long
If Target.Address <> "$A$1" Then Exit Sub
'Nur bei Eintrag in "A1" ausführen, sonst Makro verlassen
Set wksQ = Sheets("Tabelle1") 'Tabelle mit Lagerverwaltung, Name anpassen
Set wksZ = Sheets("Tabelle3") 'Tabelle für Ausgabe, Name anpassen
lngC = 3 'Zeilenzähler für den Eintrag in wksZ
wksZ.Range("A3:N65536").ClearContents 'Bereich löschen
Set rng = wksQ.Columns("M").Find(What:=Target, LookIn:=xlValues, _
LookAt:=xlWhole, After:=wksZ.Range("M65536"))
'Suche in Spalte "M" in wksQ
If Not rng Is Nothing Then
sFirst = rng.Address 'Adresse der ersten Fundstelle
With wksQ
.Range(.Cells(rng.Row, 1), .Cells(rng.Row, 14)).Copy wksZ.Cells(lngC, 1)
'bei erfolgreicher Suche, Zeile kpoieren und in wksZ ab "A3" eintragen
End With
lngC = lngC + 1 'Zeilenzähler erhöhen
Do 'schleife für Suche nach weiteren Fundstellen
Set rng = wksQ.Columns("M").FindNext(After:=rng)
'Weitersuchen
If rng.Address = sFirst Then Exit Sub
'wenn bei erster Fundstelle angelangt, Suche beenden
If Not rng Is Nothing Then
With wksQ
.Range(.Cells(rng.Row, 1), .Cells(rng.Row, 14)).Copy wksZ.Cells(lngC, 1)
End With
lngC = lngC + 1
End If
Loop
End If
End Sub

Gruß Sepp

Hallo Stefan!
Sorry das war mein Fehler!
In einem Modul muss es so sein.

Sub suchen()
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim rng As Range
Dim sFirst As String
Dim lngC As Long
Dim sFind As String
sFind = Sheets("Tabelle2").Range("A1") 'Tabellenname anpassen
Set wksQ = Sheets("Tabelle1") 'Tabelle mit Lagerverwaltung, Name anpassen
Set wksZ = Sheets("Tabelle3") 'Tabelle für Ausgabe, Name anpassen
lngC = 3 'Zeilenzähler für den Eintrag in wksZ
wksZ.Range("A3:N65536").ClearContents 'Bereich löschen
Set rng = wksQ.Columns("M").Find(What:=sFind, LookIn:=xlValues, _
LookAt:=xlWhole, After:=wksZ.Range("M65536"))
'Suche in Spalte "M" in wksQ
If Not rng Is Nothing Then
sFirst = rng.Address 'Adresse der ersten Fundstelle
With wksQ
.Range(.Cells(rng.Row, 1), .Cells(rng.Row, 14)).Copy wksZ.Cells(lngC, 1)
'bei erfolgreicher Suche, Zeile kpoieren und in wksZ ab "A3" eintragen
End With
lngC = lngC + 1 'Zeilenzähler erhöhen
Do 'schleife für Suche nach weiteren Fundstellen
Set rng = wksQ.Columns("M").FindNext(After:=rng)
'Weitersuchen
If rng.Address = sFirst Then Exit Do
'wenn bei erster Fundstelle angelangt, Suche beenden
If Not rng Is Nothing Then
With wksQ
.Range(.Cells(rng.Row, 1), .Cells(rng.Row, 14)).Copy wksZ.Cells(lngC, 1)
End With
lngC = lngC + 1
End If
Loop
Else
wksZ.Cells(lngC, 1) = "Kein Treffer!"
End If
End Sub
Gruß Sepp

Beliebteste Forumthreads (12 Monate)

In Spalte "M" Suchen &gefundene Zellen kopieren

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

In Spalte "M" Suchen &gefundene Zellen kopieren

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread