Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
224to228
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
224to228
224to228
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

suchen und kopieren

suchen und kopieren
01.03.2003 12:47:07
lucien
Hallo

Ich moechte einen Suchbegriff einer definierten Liste (z.B. in Tabelle 1 Reihe A-z) finden

Dieser gefundene Begriff muesste ich jetzt in eine tabelle 2 in die reihe 1 kopieren;
der naechste gefundene begriff soll eine zeile darunter kommen u.s.w.

Der Such code habe schon gefunden; nun braeuchte ich Hilfe um den Code zu ergaenzen.
Vielen dank im voraus
Sub MultiSeek()
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String, sFind As String
sFind = InputBox("Bitte Suchbegriff eingeben:")
For Each wks In Worksheets
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( _
prompt:="Weiter", _
Buttons:=vbYesNo + vbQuestion _
) = vbNo Then Exit Sub
Set rng = Cells.FindNext(after:=ActiveCell)
If rng.Address = sAddress Then Exit Do
Loop
End If
Next wks
MsgBox prompt:="Keine neue Fundstelle!"
End Sub

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: suchen und kopieren
01.03.2003 14:13:39
Ramses

Hallo,

das geht so:


Option Explicit

Sub MultiSeek()
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
Re: suchen und kopieren
01.03.2003 14:57:14
Lucien

Vielen Dank

Das klappt wunderbar

Auf die Gefahr hin unverschaemt zu werden. koennte man den Code noch verfeinern idem man aus suchen kann wo kopiert werden soll

Vielen dank
lucien

Re: suchen und kopieren
01.03.2003 15:01:27
Ramses

Hallo,

was meinst du damit ".. wo kopiert werden soll..."

Gruss Rainer

Re: suchen und kopieren
01.03.2003 16:02:38
Lucien

Hallo

Entschuldigung

Ich moechte dass das gefundende Ergebnis z.B. Hallo in eine Tabelle kommt die mit "H" betitelt ist, wenn das Ergebnis "Gut" heisst dann in das tabellenblatt "G".
Vielen Dank

Re: suchen und kopieren
01.03.2003 16:32:08
Ramses

Hallo,

Da es sich hier ja nur um ein Beispiel handelt, denke ich das noch mehrere Begriffe dazukommen..
Ohne Userform, mit einem erhöhten Aufwand, in der alle Tabellen aufgelistet sind ist das nicht zu lösen.

Gruss Rainer

Anzeige

304 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige