Suchen und auflisten

Sub MultiSuche() Dim Sh As Worksheet Dim GZelle As Range Dim FStelle$ Dim SBegriff SBegriff = InputBox("Bitte Suchbegriff eingeben:") For Each Sh In Worksheets Sh.Activate Set GZelle = Sh.Cells.Find(SBegriff) If Not GZelle Is Nothing Then FStelle = GZelle.Address Do GZelle.Activate If MsgBox("WeiterSuchen", vbYesNo + vbQuestion) = vbNo Then Exit Sub Set GZelle = Cells.FindNext(After:=ActiveCell) If GZelle.Address = FStelle Then Exit Do Loop End If Next Sh MsgBox ("Suche beendet.") End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Wulfgar!
Probier mal das!


Sub MultiSeek()
Dim rng As Range
Dim sFirst As String
Dim sFind As String
Dim wks As Worksheet, neu As Worksheet
Dim lRow As Long
sFind = InputBox("Geben sie das gesuchte Wort oder" & vbLf & _
"den gesuchten Wortteil ein:", "Suchen", "Suchbegriff")
If sFind = "" Then Exit Sub
Set neu = Worksheets.Add(before:=Sheets(1))
neu.Name = "Suche_" & Format(Now, "dd.mm.yy_hhmmss")
For Each wks In ThisWorkbook.Sheets
If wks.Name <> neu.Name Then
Set rng = wks.Cells.Find(What:=sFind, LookIn:=xlValues, LookAt:=xlPart)
If Not rng Is Nothing Then
sFirst = rng.Address
Do
lRow = lRow + 1
neu.Cells(lRow, 1) = rng
neu.Cells(lRow, 2) = rng.Address(0, 0)
neu.Cells(lRow, 3) = wks.Name
Set rng = wks.Cells.FindNext(rng)
Loop While rng.Address <> sFirst
End If
End If
Set rng = Nothing
Next
End Sub

Gruß Sepp
P.S.: Rückmeldung nicht vergessen!

Sub MultiSeek() Dim rng As Range Dim sFirst As String Dim sFind As String Dim wks As Worksheet, neu As Worksheet Dim lRow As Long sFind = InputBox("Geben sie das gesuchte Wort oder" & vbLf & _ "den gesuchten Wortteil ein:", "Suchen", "Suchbegriff") If sFind = "" Then Exit Sub Set neu = Worksheets.Add(before:=Sheets(1)) neu.Name = "Suche_" & Format(Now, "dd.mm.yy_hhmmss") For Each wks In ThisWorkbook.Sheets If wks.Name <> neu.Name Then Set rng = wks.Cells.Find(What:=sFind, LookIn:=xlValues, LookAt:=xlPart) If Not rng Is Nothing Then sFirst = rng.Address Do lRow = lRow + 1 wks.Rows(rng.Row).Copy neu.Cells(lRow, 1) Set rng = wks.Cells.FindNext(rng) Loop While rng.Address <> sFirst End If End If Set rng = Nothing Next End Sub

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Suchen und auflisten

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread