Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender Navigationstipps
Inhaltsverzeichnis

Suchfunktion unter Excel

Suchfunktion unter Excel
14.12.2003 17:38:30
Bjoern
Möchte in Excel (VBA) eine Suchfunktion erstellen in der er aus einer Tabelle Daten sucht und diese in eine andere Tabelle schreibt! Diese Daten haben mehere Spalten und ein Suchbegriff kann auch mehrmals auftauchen und muß somit auch mehrmal gesucht werden und auch alle Sucherhgebnisse in die andere Tabelle eingetragen werden! Hat jemand vielleicht einen Tip oder sogar einen Quelltext?
Das wäre ehr nett!

Danke schonmal im vorraus!


bjoern

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Suchfunktion unter Excel
14.12.2003 17:57:56
Ramses
Hallo

hier mal ein Quelltext zum anpassen :-)


ub MultiSeek()
'Original Unknown
'Modified 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, sFind As String
Dim Cr As Long, tarWks As String
tarWks = "Tabelle2" '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
sFind = InputBox("Bitte Suchbegriff eingeben:")
For Each wks In Worksheets
    If wks.Name = tarWks Then GoTo Exitfor
    Set rng = wks.Cells.Find(what:=sFind, _
                    lookat:=xlWhole, LookIn:=xlFormulas)
    If Not rng Is Nothing Then
        sAddress = rng.Address
        Do
            Application.GoTo rng, True
            If MsgBox("Weiter und kopieren", vbYesNo + vbQuestion) = vbNo Then Exit Sub
            wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(Cr)
            Cr = Cr + 1
            Set rng = Cells.FindNext(after:=ActiveCell)
            If rng.Address = sAddress Then Exit Do
        Loop
    End If
Exitfor:
Next wks
MsgBox prompt:="Keine neue Fundstelle!"
End Sub 
     Code eingefügt mit Syntaxhighlighter 1.16



Gruss Rainer
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige