Suche über Mappe - Treffer in Neue

Mahlzeit.
Ich benötige eure Hilfe für folgende Problemstellung:
Ich habe eine Arbeitsmappe mit diversen Tabellenblättern (alle sind identisch aufgebaut) und ich möchte nun über einen Button eine Suchfunktion öffnen lassen.
Nach Eingabe meines Suchbegriffes sollen alle Tabellen durchsucht werden (hier möchte ich eine Einschränkung auf einen bestimmten Suchbereich haben) und alle Zeilen mit einem Treffer sollen komplett in einer neuen Arbeitsmappe ausgewiesen werden.
Wichtig dabei ist auch, dass eine "Wertkopie" erstellt wird, da viele Einträge in den Zellen aus einer Datenbank kommen. Die Formate (Farbe, Nachkommastellen etc.) sollen ebenfalls übermommen werden.
Am Ende der Suche soll ein Hinweisfenster erscheinen mit "Die Suche wurde beendet" (wenn sogar die Trefferanzahl erscheinen würde wäre es genial). Nach Bestätigung dieser Meldung soll man dann auf das Ergebnisblatt in der neuen Arbeitsmappe kommen.
Für jegliche Hilfe bin ich dankbar.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo nochmals!
Inzwischen habe ich im Forum einen Eintrag gefunden, der mir schon ein wenig weiterhilft. Allerdings bleiben noch offene Fragen. Ich habe in den Tabellenblättern zum Teil Datenbankverweise und Formeln und die Suche darf sich nur auf den Ausgebwert beschränken (sprich keine Formel soll z.B. nach einem Buchstaben durchsucht werden). Das ist mein Problem 1. Das Problem 2 ist, dass ich den Suchbereich für allen Blätter auf bestimmte Bereiche eingrenzen möchte. Wo muss das eingebaut werden? Problem 3. Bei der Zieltabelle sollte nach Möglichkeit eine "Wertkopie" erstellt werden zum Abschluss.
Hier mal mein Code:


Sub Var_MultiSeek()
'by Ramses
'Sucht in der gesamten Mappe nach einem Begriff und kopiert die
'gefundene Zeile in eine zu definfierende Ergebnistabelle
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String
'Suchbegriff
Dim sFind As Variant
Dim cr As Long, tarWks As String
'Name_der_Zieltabelle
'Bitte Anpassen !!!!
tarWks = "Zieltabelle"
cr = 65536
If Worksheets(tarWks).Cells(cr, 1) = "" Then
cr = Worksheets(tarWks).Cells(cr, 1).End(xlUp).Row
End If
If cr = 0 Then cr = 1
'Suchbegriff definieren
sFind = InputBox("Bitte Suchbegriff eingeben:")
If sFind = "" Then Exit Sub
'Suchbegriff auf Zelle definieren
'sFind = Worksheets("Tabelle1").Range("A1")
For Each wks In Worksheets
'If wks.Name = tarWks Then Exit Sub
If wks.Name <> tarWks Then
Set rng = wks.Cells.Find(What:=sFind, _
lookat:=xlPart, LookIn:=xlFormulas)
If Not rng Is Nothing Then
sAddress = rng.Address
Do
Application.GoTo rng, True
'Für die Automation kann die "If"-Anweisung auskommentiert werden
'If MsgBox("Suchbegriff: " & sFind & ",gefunden in " _
& wks.Name & ", " & rng.Address, vbYesNo + vbQuestion, "Weitersuchen ?") = vbNo Then Exit Sub
wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(cr)
cr = cr + 1
Set rng = wks.Cells.FindNext(after:=ActiveCell)
If rng.Address = sAddress Then Exit Do
Loop
End If
NextStart:
End If
Next wks
MsgBox prompt:="Keine neue Fundstelle!"
End Sub

Sub Var_MultiSeek() 'by Ramses 'Sucht in der gesamten Mappe nach einem Begriff und kopiert die 'gefundene Zeile in eine zu definfierende Ergebnistabelle Dim wks As Worksheet Dim rng As Range Dim sAddress As String 'Suchbegriff Dim sFind As Variant Dim cr As Long, tarWks As String 'Name_der_Zieltabelle 'Bitte Anpassen !!!! tarWks = "Zieltabelle" cr = 65536 If Worksheets(tarWks).Cells(cr, 1) = "" Then cr = Worksheets(tarWks).Cells(cr, 1).End(xlUp).Row End If If cr = 0 Then cr = 1 'Suchbegriff definieren sFind = InputBox("Bitte Suchbegriff eingeben:") If sFind = "" Then Exit Sub 'Suchbegriff auf Zelle definieren 'sFind = Worksheets("Tabelle1").Range("A1") For Each wks In Worksheets 'If wks.Name = tarWks Then Exit Sub If wks.Name <> tarWks Then Set rng = wks.Cells.Find(What:=sFind, _ lookat:=xlPart, LookIn:=xlValues) If Not rng Is Nothing Then sAddress = rng.Address Do Application.GoTo rng, True 'Für die Automation kann die "If"-Anweisung auskommentiert werden 'If MsgBox("Suchbegriff: " & sFind & ",gefunden in " _ & wks.Name & ", " & rng.Address, vbYesNo + vbQuestion, "Weitersuchen ?") = vbNo Then Exit Sub wks.rng.Copy Destination:=Worksheets(tarWks).Rows(cr) cr = cr + 1 Set rng = wks.Cells.FindNext(after:=ActiveCell) If rng.Address = sAddress Then Exit Do Loop End If NextStart: End If Next wks MsgBox prompt:="Keine neue Fundstelle!" End Sub

Beliebteste Forumthreads (12 Monate)

Suche über Mappe - Treffer in Neue

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Suche über Mappe - Treffer in Neue

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

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread