Makro erweitern

Hallo Matthias,

ich hab' das Makro nach Deinem Wunsch angepasst.
Ich hoffe es gefällt Dir.

Sub DatenSuchenKopieren()
'Suchabfrage mit der möglichkeit, die Fundstelle mit
'weiteren daten in ein anderes Blatt zu kopieren
'Suchabfrage wird bis zum Abbruch wiederholt
'von J.Ehrensberger
Dim bereich As Range       'Suchbereich
Dim rng As Range
Dim sAddress As String
Dim sFind As String        'Suchbegriff
Dim lngE As Long           'Erste leere Zeile im Zielblatt
lngE = Sheets("TB2").Range("A65536").End(xlUp).Row + 1   'Tabellenname anpassen
Set bereich = Sheets("TB1").Range("C1:C1000")
'Suchbereich - Tabellenname und Spalte(Bereich) anpassen
   Do 'Schleife für Suchabfrage
   sFind = InputBox("Bitte geben Sie den Suchbegriff ein!", "Suche", "Suchtext")
      If sFind = "" Then Exit Do
   Set rng = bereich.Find(What:=sFind, LookAt:=xlWhole, LookIn:=xlValues)
            'LookAt:=xlPart - wenn auch Teilstring gefunden werden soll
      If Not rng Is Nothing Then
      sAddress = rng.Address
         Do 'Schleife für aktuellen Suchbegriff
         rng.Activate
            If MsgBox("Wollen Sie den gefundenen Datensatz kopieren" & vbLf & _
            "und die Suche nach " & sFind & " abbrechen?", _
            vbYesNo + vbQuestion, "Kopieren") = vbYes Then
            Range(Cells(rng.Row, 3), Cells(rng.Row, 5)).Copy Sheets("TB2").Cells(lngE, 1)
                              'Tabellenblattname und Spalten von - bis anpassen
            lngE = lngE + 1   'Zeilenzähler erhöhen
            Exit Do  'Innere Schleife verlassen
            Else
            Set rng = Cells.FindNext(after:=rng)
               If rng.Address = sAddress Then Exit Do 'Schleife bei erreichen des ersten
                                                      'Suchbegriffes verlassen
            End If
         Loop  'Umkehrpunkt der inneren Schleife
      End If
''Info über Ende der Suchabfrage, bei Bedarf Auskommentierung entfernen
'   MsgBox "Suche nach "" " & sFind & " "" wurde beendet!", _
'      vbOKOnly + vbExclamation, "Suche Beendet"
   Loop  'Umkehrpunkt der äusseren Schleife
End Sub

Code eingefügt mit Syntaxhighlighter 2.5

Die MsgBox am Ende habe ich auskommentiert, wenn Du sie sehen möchtest,
dann einfach die Hochkommas am Zeilenanfang wegmachen.

Gruß Sepp

Hi Matthias,

versuch mal wie Dir das gefällt.

Sub DatenSuchenKopieren()
'von J.Ehrensberger
Dim bereich As Range
Dim rng As Range
Dim sAddress As String
Dim sFind As String
Dim lngE As Long
lngE = Sheets("TB2").Range("A65536").End(xlUp).Row + 1   'Tabellenname anpassen
Set bereich = Sheets("TB1").Range("C1:C1000")
'Suchbereich - Tabellenname und Spalte(Bereich) anpassen
sFind = InputBox("Bitte geben Sie den Suchbegriff ein!", "Suche", "Suchtext")
   If sFind = "" Then Exit Sub
Set rng = bereich.Find( _
   what:=sFind, _
   lookat:=xlWhole, _
   LookIn:=xlValues)
   If Not rng Is Nothing Then
   sAddress = rng.Address
      Do
      rng.Activate
         If MsgBox("Wollen Sie den gefundenen Datensatz kopieren" & vbLf & _
         "und die Suche abbrechen?", vbYesNo + vbExclamation, "Kopieren") = vbYes Then
         Range(Cells(rng.Row, 3), Cells(rng.Row, 5)).Copy Sheets("TB2").Cells(lngE, 1)
         'Tabellenblattname und Spalten von - bis anpassen
         Exit Sub
         Else
         Set rng = Cells.FindNext(after:=ActiveCell)
            If rng.Address = sAddress Then Exit Do
         End If
      Loop
   End If
MsgBox prompt:="Suche nach "" " & sFind & " "" wurde beendet!", _
   Buttons:=vbOKOnly + vbExclamation
End Sub

Code eingefügt mit Syntaxhighlighter 2.5

Ich bin jetzt eine weile nicht am PC, schau aber später wieder vorbei.

Gruß Sepp

Sub DatenSuchen() Dim cell As Range Dim str As String str = InputBox("Bitte geben Sie den Suchbegriff ein!") If str = "" Then Exit Sub For Each cell In Selection If cell = str Then cell.Select Exit Sub End If Next cell MsgBox "Suchbegriff nicht gefunden!" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread