|  
                                             Hier aus einem Projekt: 
  
Beachte die Kommentare: 
Option Explicit
Private Const sZIELARBEITSBLATTNAME As String = "Ziel" '**** hier kommt der Zielarbeitsblattname hin
Sub main()
    Dim wks             As Excel.Worksheet
    Dim sSuchbegriff    As String
    
    On Error GoTo FinishErr
    
    sSuchbegriff = "Bauer" '*** hier Deine Inputbox
    
    
    '*** Übersichtsblatt zurücksetzen
    Worksheets(sZIELARBEITSBLATTNAME).Cells.ClearContents
    Worksheets(sZIELARBEITSBLATTNAME).Cells.ClearFormats
    Application.ScreenUpdating = False
    '*** durchlaufe jedes Arbeitsblatt; ausser Zielarbeitsblatt
    For Each wks In ThisWorkbook.Worksheets
        If Not wks.Name = Worksheets(sZIELARBEITSBLATTNAME).Name Then
            Call FrageArbeitsblatt(wks.Name, sSuchbegriff)
        End If
    Next wks
    
FinishErr:
Application.ScreenUpdating = True
End Sub
Sub FrageArbeitsblatt(ByVal sName As String, ByVal sSuchWert As String)
    Dim rngFilterBereich            As Excel.Range
    Dim rngIntersect                As Excel.Range
    
    With Worksheets(sName)
        '*** Möglichen Filter entfernen
        If .AutoFilterMode = True Then .AutoFilterMode = False
        '*** Autofilter anwenden und Filter setzen
        Set rngFilterBereich = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
        rngFilterBereich.AutoFilter Field:=2, Criteria1:=sSuchWert
        '*** Bereich zum kopieren definieren
        Set rngIntersect = Application.Intersect(rngFilterBereich, rngFilterBereich.Offset(1, 0), rngFilterBereich.SpecialCells(xlCellTypeVisible))
        '*** Falls was vorhanden, in Überischtsblatt übertragen
        If Not rngIntersect Is Nothing Then
            Call rngIntersect.Copy
            Call Worksheets(sZIELARBEITSBLATTNAME).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial(xlPasteValuesAndNumberFormats)
            Application.CutCopyMode = False
            .UsedRange.EntireColumn.AutoFit
            Application.Goto Reference:=Worksheets(sZIELARBEITSBLATTNAME).Range("A1")
        End If
        '*** Filter lösen
        rngFilterBereich.AutoFilter
        .AutoFilterMode = False
    End With
    
End Sub
  
     |