AW: Suchmaske für Tabelle
29.09.2004 09:53:36
Marsi
Hallo Tobias,
ich habe ein Code gefunden und modifiziert.
Ich komme schon weiter, aber es wird immer eine Meldung angezeigt "Keine neue Fundstelle", obwohl dieser Datensatz da ist. siehe Code unten...
>tarWks = "Daten1" 'Name_der_Zieltabelle --> habe ich gemacht....
>'sFind = Worksheets("Daten1").Range("D1") --> habe ich auch gemacht, damit er nur in Spalte D durchsucht.
Scheint aber nicht zu klappen .......
Danke im voraus.
Gruß, Frank
Gruß, FRank
'---------------------------
Sub Suchen()
'Original Unknown
'Sucht in dergesamten Mappe nach einem Begri und kopiertdie
'gefundene Zeile in eine zu definfierende Ergebnistabelle
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String, sFind As String
Dim cr As Long, tarWks As String
tarWks = "Tabelle3" 'Name_der_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("Daten1").Range("D1")
For Each wks In Worksheets
If wks.Name = tarWks Then GoTo NextStart
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 "Keine neue Fundstelle!"
End Sub
'----------------------------------