Option Explicit
Private Const sZIELARBEITSBLATTNAME As String = "Ziel"
Sub main()
Dim wks As Excel.Worksheet
Dim sSuchbegriff As String
On Error GoTo FinishErr
sSuchbegriff = "Bauer"
Worksheets(sZIELARBEITSBLATTNAME).Cells.ClearContents
Worksheets(sZIELARBEITSBLATTNAME).Cells.ClearFormats
Application.ScreenUpdating = False
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)
If .AutoFilterMode = True Then .AutoFilterMode = False
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
Set rngIntersect = Application.Intersect(rngFilterBereich, rngFilterBereich.Offset(1, 0), rngFilterBereich.SpecialCells(xlCellTypeVisible))
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
rngFilterBereich.AutoFilter
.AutoFilterMode = False
End With
End Sub