Suchen und einfügen
21.01.2020 09:27:04
Mike
(hier die Formel, Danke nochmals an Piet)
Option Explicit
Dim rFind As Range, SuchTxt As String
Sub Daten_suchen_kopieren_Find()
Dim TB2 As Worksheet 'Tabelle2
Set TB2 = Worksheets("Blatt2")
'With Klammer vereinfacht Schreibweise
With Worksheets("Blatt1")
SuchTxt = .Range("A4").Value 'Suchlauf nach Suchtext
Set rFind = TB2.Columns(1).Find(What:=SuchTxt, After:=Cells(1, 1), LookIn:= _
xlFormulas, LookAt:=xlPart, SearchDirection:=xlNext, MatchCase:=False)
'Fehlermeldung wenn Suchtext nicht gefunden wird
If rFind Is Nothing Then MsgBox SuchTxt & " nicht gefunden!": Exit Sub
'Suchtext kopieren und einfügen
If Not rFind Is Nothing Then
.Range("A4:KM4").Copy rFind
End If
End With
End Sub
Sub Daten_suchen_kopieren_ForNx()
Dim AC As Range, lz1 As Long
Dim TB2 As Worksheet 'Tabelle2
Set TB2 = Worksheets("Blatt2")
'Dasselbe über For Next Schleife
With Worksheets("Blatt1")
SuchTxt = .Range("A4").Value
lz1 = TB2.Cells(Rows.Count, 1).End(xlUp).Row
For Each AC In TB2.Range("A1:A" & lz1)
If AC.Value = SuchTxt Then
.Range("A4:KM4").Copy AC
Exit For
End If
Next AC
End With
End Sub