Jokerzeichen vor und nach Suchbegriff automatisch
Wolfgang
den nachstehenden Code hat mir Franz zur Verfügung gestellt. Er läuft auch soweit wunderbar. Ich habe jetzt nur festgestellt, dass das Suchwort evtl. mitten zwischen anderern Wörtern stehen kann. Wäre denkbar, dass, wenn das Suchwort eingegeben wurde, automatisch davor und dahinter die Jokerzeichen * gesetzt werden könnten? - Danke schon jetzt für die Rückmeldungen.
Gruß - Wolfgang
Sub SuchenKopieren()
Static Suchbegriff As String
Dim Zelle As Variant, ErsteAdresse As String
Dim LetzteZeile As Integer
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
Set wksQuelle = Worksheets("Maßnahmen")
Set wksZiel = Worksheets("Einstellung")
Application.ScreenUpdating = False
wksZiel.Range("A14:H1000").Cells.Clear 'Alte Tabelleninhalte löschen
Suchbegriff = InputBox(Prompt:="Bitte Suchbegriff eingeben:", _
Default:=Suchbegriff)
If Suchbegriff = "" Then
MsgBox "Bitte Suchbegriff eingeben", vbCritical
Exit Sub
End If
With wksQuelle
'Überschriftenzeile kopieren ...
.Range("A1:H1").Copy Destination:=wksZiel.Range("A14")
'Suche in Spalte H
Set Zelle = .Columns(8).Find(What:=Suchbegriff, After:=.Range("H1"), _
LookIn:=xlValues, lookat:=xlWhole, _
SearchOrder:=xlNext, MatchCase:=True)
If Not Zelle Is Nothing Then
ErsteAdresse = Zelle.Address
LetzteZeile = 15
Do
'gefundenen Zeile Spalten A bis H kopieren in nächste Zeile im Zielblatt
.Range(.Cells(Zelle.Row, 1), .Cells(Zelle.Row, 8)).Copy _
Destination:=wksZiel.Cells(LetzteZeile, 1)
'Suche wiederholen
Set Zelle = .Columns(8).FindNext(Zelle)
LetzteZeile = LetzteZeile + 1
Loop While Not Zelle Is Nothing And Zelle.Address ErsteAdresse
End If
End With
wksZiel.Select
Range("A1").Select
Application.ScreenUpdating = True
End Sub