Tabellen durchsuchen
11.04.2008 14:02:09
Manfred
habe den u.g. CODE aus dem Forum, er funzt auch super.
Kann mir jemand sagen wie ich den CODE ändern muß damit das Einschreiben der gefundenen Daten auf der Seite "Suchergebnis" erst ab Zelle A2 beginnt ? Habs versucht, bekomme es aber nicht hin.
Sub alles_Durchsuchen()
'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 = "Suchergebnis"
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
Mit freundlichen Grüßen
Manfred