Hallo

Anbei erst mal der Code, damit die Kopie deiner Zeilen ausgegeben wird. Ich hoffe das ich es richtig verstanden habe.

Meld Dich halt zurück.

Private Sub CommandButton1_Click()
 
Dim Meldung         As Byte, Pos        As Byte
Dim Schleife        As Byte, y          As Byte
Dim Begriff, Suchen()                   As Variant
Dim Bereich                             As Range
Dim n%, x%, xZelle%, yZelle%
Dim xTabelle$(), Adresse$(), Text$
 
 
' Suchbegriff eingeben
Begriff = InputBox _
("Bitte den zu suchenden Begriff eingeben. Sollen 2 Werte" & vbCrLf & _
 "gleichzeitig gesucht werden, dann mit Zeichen  +  " & vbCrLf & _
 "voneinander trennen (z.B.: Summe+die)." & vbCrLf & vbCrLf & _
 "ENTER ohne Wert = Abbruch", "S U C H M O D U S")
If Begriff = "" Then Exit Sub
 
Pos = InStr(Begriff, "+")
If Pos Then
    ReDim Suchen(2)
    Suchen(1) = Left(Begriff, Pos - 1)
    Suchen(2) = Right(Begriff, Len(Begriff) - Pos)
    Schleife = 2
Else
    ReDim Suchen(1)
    Suchen(1) = Begriff
    Schleife = 1
End If
 
Application.ScreenUpdating = False
 
 
' Eigentlicher Suchvorgang (in allen Tabellenblättern)
x = 1
For y = 1 To Schleife
  For n = 1 To Sheets.Count
   
  ' Letzte Zelle des Bereiches ermitteln. Diese Zelle wird als Startzelle für
  ' die Suche deffiniert, da Suche nach dieser Zelle, also in erster Zelle
  ' des Bereiches beginnt.
  'Bereich festlegen
  Set Bereich = Worksheets(n).UsedRange
   
   
  With Worksheets(n).Range(Bereich.Address)
      xZelle = .Columns(.Columns.Count).Column
      yZelle = .Rows(.Rows.Count).Row
  End With
  With Sheets(n).Range(Bereich.Address)
      Set c = .Find(Suchen(y), after:=Cells(yZelle, xZelle), LookIn:=xlValues)
      If Not c Is Nothing Then
          ErsteAdresse = c.Address
          Do
              ReDim Preserve Adresse(x): ReDim Preserve xTabelle(x)
              xTabelle(x) = Sheets(n).Name
              Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
              Set c = .FindNext(c)
              x = x + 1
          Loop While Not c Is Nothing And c.Address <> ErsteAdresse
      End If
  End With
  Next n
Next y
 
 
Application.ScreenUpdating = True
 
' Die Anzahl der gefundenen Werte ist (x - 1), wenn keiner
' gefunden wurde dann ist x = 1
Select Case x
Case 1
    Meldung = MsgBox("Es wurde kein übereinstimmender Wert gefunden", _
    vbOKOnly, "G E F U N D E N E   W E R T E")
    Exit Sub
Case Else
    Meldung = MsgBox("Es wurden " & (x - 1) & " Übereinstimmungen gefunden.", _
    vbOKOnly, "G E F U N D E N E   W E R T E")
'Tabelle einfügen
'Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
On Error Resume Next
With ActiveSheet
    .Name = "Startseite"
    .[I5] = "Suchergebnis"
     
 
    For n = 1 To x - 1
        .Cells(n + 7, 9) = xTabelle(n)
        .Cells(n + 7, 10) = Begriff
    Next n
End With
End Select
 
 
End Sub

Gruß & Frohe Ostern

Den Rest versuche ich noch zu klären