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

Danke zunächst für die schnelle Zusendung des Codes. Leider funktioniert dies nicht. Als erstes wird Sub main() als Fehler ausgewiesen, dann wird wieder nach Object gesucht. Eine ähnliche Variante hatte ich auch schon ausprobiert. Es will einfach nicht funktionieren.

Private Sub CommandButton4_Click()

'Button Anzahl Todesfälle / Jahr

Dim suche As String
Dim z As Integer
Dim x As Object
Dim Blatt As Object
Dim Worksheet As Object
Dim rngBereich As Range

   suche = InputBox("Geben Sie bitte das Jahr ein!", , "2014")
   
   z = 0
   If suche = "" Then Exit Sub
   
   For Each Blatt In ActiveWorkbook.Worksheets
       For Each x In Blatt.UsedRange
          If x = suche Then
            z = z + 1
          End If
        
          
    Next x
  Next Blatt
                
             MsgBox suche & " wurde " & z & "  mal gefunden."
             
 

  End Sub

 

Ich habe eine Code geschrieben, da wird jedes Suchwort in jeder Tabelle farblich gekennzeichnet.  Gefunden wird dies schon, aber es ist umständlich und aufwendig.Aber trotzdem noch einmal vielen Dank. 

P.S. was bin ich Ihnen schuldig?