Anzeige
Archiv - Navigation
624to628
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
624to628
624to628
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Suchen und Ergebnis anzeigen
22.06.2005 16:49:20
Bernd
Hallo,
eine Suchfunktion ist eingebaut, stimmt, aber es leifert mir nicht den gewünschten Effekt. Habe hier ein Makro gefunden, das mir alles zählt, und jetzt müsste es nur noch eine Zusammenfassung auf einem Extra Tabellenblatt geben mit Anzahl und Tabellenblattnamen, wo er die Werte gefunden hat, und das kann eben die im Excel eingebaute Suchfunktion nicht.
Hier ein mögliches Makro:

Sub suchen()
Windows("Ausrüstungsblätter Kader.xls").Activate
Dim Zelle As Range, Suchbegriff As String, Adresse As String, zaehler As Integer
Dim index As Integer, Feld() As String, Tabelle() As Integer, Zeile_Spalte() As String
Dim Suche As Variant
i = 3
Suchbegriff = InputBox("Suchbegriff eingeben", "Eingabe")
If Suchbegriff <> "" Then
For index = 1 To Worksheets.Count
With Sheets(index).Cells
Set Zelle = .Find(What:=Trim(Suchbegriff), LookAt:=xlPart)
If Not Zelle Is Nothing Then
Adresse = Zelle.Address
Do
zaehler = zaehler + 1
ReDim Preserve Feld(1 To zaehler)
ReDim Preserve Tabelle(1 To zaehler)
ReDim Preserve Zeile_Spalte(1 To zaehler)
Feld(zaehler) = Sheets(index).Name & " Spalte " & Zelle.Column & " Zeile " & Zelle.Row
Tabelle(zaehler) = index
Zeile_Spalte(zaehler) = Zelle.Address
Set Zelle = .FindNext(Zelle)
Loop While Not Zelle Is Nothing And Zelle.Address <> Adresse
End If
End With
Next
If zaehler > 0 Then
If MsgBox(Suchbegriff & " wurde " & CStr(zaehler) & " mal gefunden." & vbNewLine & "Fundstellen übertragen?", 68, "Information") = 7 Then Exit Sub
Do
For index = 1 To zaehler
Windows("Ausrüstungsblätter Kader.xls").Activate
Sheets(Tabelle(index)).Select
Range(Zeile_Spalte(index)).Select
ActiveWindow.ScrollColumn = Selection.Column
ActiveWindow.ScrollRow = Selection.Row
Suche = ActiveWindow.ScrollRow
If Suche > 2 Then
Range("A" & Suche & ":CM" & Suche).Select
Selection.Copy
Blattname = ActiveSheet.Name
ThisWorkbook.Activate
Cells(2, 1).Value = Blattname
Cells(i, 1).Select
i = i + 1
ActiveSheet.Paste
Else
GoTo weiter
End If
weiter:
If zaehler = 1 Then Exit Sub
If index < zaehler Then
'If MsgBox(CStr(index) & ". Fundstelle von " & CStr(zaehler) & ": " & Feld(index) & vbNewLine & "Weitere anzeigen?", 68, "Information") = 7 Then Exit Sub
Else
If MsgBox(CStr(index) & ". Fundstelle von " & CStr(zaehler) & ": " & Feld(index) & vbNewLine & "Nochmal übertragen?", 68, "Information") = 7 Then Exit Do
End If
Next
Loop
Else
MsgBox Suchbegriff & " wurde nicht gefunden", 64, "Information"
End If
End If
ThisWorkbook.Activate
End Sub

Wenn ich am Ende auf weiter gehe, erhalte ich eine Fehlermeldung.
Bin für jede Hilfe Dankbar

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Suchen und Ergebnis anzeigen
23.06.2005 10:49:54
opaharry
Dieses Makro erstellt dir ein neues Tabellenblatt
und listet alle gefundenen Suchbegriffe auf.
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", "")

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
Anzeige

310 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige