|
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
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
|