http://Test.xlsDanke für die schnelle Antwort.

Das Sperrwort lautet: ekpos

Steht in der Arbeitsmappe:

Option Explicit

Private Const sZIELARBEITSBLATTNAME As String = "Ziel" '**** hier kommt der Zielarbeitsblattname hin

Steht bei Start = ist ein Tabellenblatt (Eingangsmenü: mehrere Codes über Button erstellt)  

Sub main()

    Dim wks             As Excel.Worksheet

    Dim sSuchbegriff    As String

    On Error GoTo FinishErr

    sSuchbegriff = InputBox("Geben Sie bitte den Namen ein!", , "Bauer")

 z = 0

   If sSuchbegriff = "" Then Exit Sub

   For Each Blatt In ActiveWorkbook.Worksheets

       For Each x In Blatt.UsedRange

          If x = sSuchbegriff Then

            z = z + 1

          End If

    Next x

  Next Blatt

             MsgBox sSuchbegriff & " wurde " & z & "  mal gefunden."

    '*** Ü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 Suche 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:=Suche

        '*** Bereich zum kopieren definieren

        Set rngIntersect = Application.Intersect(rngFilterBereich, rngFilterBereich.Offset(1, 0), rngFilterBereich.SpecialCells(xlCellTypeVisible))

        '*** Falls was vorhanden, in Übersichtsblatt ü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