Automatische Suche über Tabellenblätter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
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 = "Tabelle3"
    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
        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:
    Next wks
    MsgBox prompt:="Keine neue Fundstelle!"
End Sub

Gruss Rainer

Hallo Michael und Rainer,
da ich nicht nur "meckern" will, hier eine geänderte Version:


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 = "Tabelle3"
With Worksheets(tarWks)
If .Cells(.Rows.Count, 1) <> "" Then MsgBox "Zielltabelle voll": Exit Sub
cr = .Cells(.Rows.Count, 1).End(xlUp).Row
If cr = 1 And .Cells(1, 1) = "" Then cr = 0
'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
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
cr = cr + 1
wks.Rows(rng.Row).Copy Destination:=.Rows(cr)
Set rng = wks.Cells.FindNext(after:=ActiveCell)
If rng.Address = sAddress Then Exit Do
Loop
End If
End If
Next wks
MsgBox prompt:="Keine neue Fundstelle!"
End With
End Sub

Noch was: In der Vorversion stand
If wks.name = tarWks Then Exit Sub
Damit wwurde die Prozedur sofort verlassen, wenn Sheets(tarWks) das erste Blatt ist,
Blätter hinter tarWks werden nicht abgesucht.
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Beliebteste Forumthreads (12 Monate)

Automatische Suche über Tabellenblätter

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Automatische Suche über Tabellenblätter

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread