Hi ViktorP.

Die Lösungsansätze auf Herber sind doch ok, warum hier noch mal ein Beitrag zu dem Thema?

Ich hab das mit der Hilfe aus Herbers EXcel-Forum nicht geschafft

Wirklich? Das ist deine Begründung? Du könntest dort auch einfach sagen warum du damit nicht weiter kommst und dir würde geholfen, anstatt dessen bist du nun hier.

Tipp für die Zukunft: Sich selbst und andere belügen... keine gute Einstellung um - im Leben und anderswo - voran zu kommen.

Zurück zum Thema:

Eine Sache läßt mich immer noch Stirnerunzeln.

Der Zellenbereich BE1:CO44 ist nicht lückenlos gefüllt.

Das bedeutet, dass in Zeile 6 bzw. 7 eines Treffers auch mal nichts stehen könnte? Falls dem so ist, wird das im folgenden Makro nicht berücksichtigt

Option Explicit

Public Sub Test()
  
  Dim rngCriteria As Excel.Range
  Dim rngData As Excel.Range
  Dim rngOut As Excel.Range
  
  'Wo steht der Wert, nach dem gesucht werden soll?
  Set rngCriteria = Worksheets("Tabelle2").Range("B1")
  'In welchem Bereich soll gesucht werden?
  Set rngData = Worksheets("Tabelle1").Range("BE1:CO44")
  'Ab welcher Zelle soll die Ausgabe erfolgen?
  Set rngOut = Worksheets("Tabelle2").Range("C4")
  
  Dim rngResult As Excel.Range
  
  'Ausgabebereich prüfen, bevor es losgeht
  If rngOut.Value <> "" And rngOut.Offset(1).Value <> "" Then
    Select Case MsgBox("Der Ausgabebereich enthält bereits Daten!" & vbNewLine & vbNewLine _
                       & "Möchten Sie die Daten im Ausgabebereich behalten?", _
                       vbYesNoCancel + vbDefaultButton3 + vbQuestion, _
                       "Daten behalten?")
      Case vbYes
      'Daten behalten
        Set rngOut = rngOut.End(xlDown).Offset(1)
      Case vbNo
      'Daten löschen
        With rngOut.Worksheet
          .Range(rngOut, rngOut.End(xlDown)).ClearContents
        End With
      Case Else 'vbCancel
      'Abbruch
        Exit Sub
    End Select
  End If
  
  'Suche starten
  Set rngResult = rngData.Find(What:=rngCriteria.Value, _
                               LookIn:=xlValues, LookAt:=xlWhole, _
                               SearchOrder:=xlByRows, MatchCase:=False)
  
  If Not rngResult Is Nothing Then
    
    Dim strFirstAddr As String
    Dim n As Long
    
    strFirstAddr = rngResult.Address
    Do
      n = n + 1
      With rngResult.Worksheet
        rngOut.Resize(2, 1).Value = .Cells(6, rngResult.Column).Resize(2, 1).Value
        Set rngOut = rngOut.Offset(2)
      End With
      'weiter suchen
      Set rngResult = rngData.FindNext(rngResult)
    Loop While rngResult.Address <> strFirstAddr
    
    Call MsgBox("Suche nach: '" & rngCriteria.Value & "'" & vbNewLine _
                & "-> " & n & " Treffer", vbInformation)
  Else
    Call MsgBox("Suche nach: '" & rngCriteria.Value & "'" & vbNewLine _
                & "-> Keine Treffer", vbInformation)
  End If
  
End Sub

Grüße