Excel: Filtern aus mehreren Arbeitsblättern mit Ergebniss in einem neuen AB

Option Explicit

Sub BlattErstellenMitKgleichEundNgleichxAufBlatt1Und2()

 Const cBericht_BLATTNAME = BERICHT_E_x->Zielblatt
 Const cZ_UEB = 1->Überschriftenzeile
 Const cZ_AB = 2->Zeilen sind zu finden ab Zeile:
 Const cSP_K = 11->Spalte K
 Const cSP_K_TXT = E
 Const cSP_N = 14->Spalte N
 Const cSP_N_TXT = x
 
 
 Dim QuellBlaetter As Variant
->Quellblaetter (müssen alle das gleiche Format haben)
 QuellBlaetter = Array(Tabelle 3, Tabelle 4)
 
 Dim ws As Worksheet, wsq As Worksheet, Zelle As Range, r As Range
 Dim zz As Long, lCols As Long, lRows As Long, sp As Long, x As Long
 Dim ersterFundort As String
 
 Application.ScreenUpdating = False
 
->ggf. vorhandenes Berichtsblatt löschen
 On Error Resume Next
 Set ws = ThisWorkbook.Worksheets(cBericht_BLATTNAME)
 Application.DisplayAlerts = False
 ws.Delete
 Application.DisplayAlerts = True
 On Error GoTo 0
 
->Berichtsblatt anlegen
 Set ws = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets(1))

 ws.Name = cBericht_BLATTNAME
->Format und Überschrift kopieren aus 1.Blatt
 Set wsq = ThisWorkbook.Worksheets(QuellBlaetter(0))
 lCols = wsq.UsedRange.Column + wsq.UsedRange.Columns.Count - 1-> Anzahl benutzte Spalten
 For sp = 1 To lCols
  ws.Columns(sp).NumberFormat = wsq.Cells(cZ_AB, sp).NumberFormat
  ws.Columns(sp).ColumnWidth = wsq.Cells(cZ_AB, sp).ColumnWidth
  ws.Cells(cZ_UEB, sp).NumberFormat = wsq.Cells(cZ_UEB, sp).NumberFormat
  ws.Cells(cZ_UEB, sp).Value = wsq.Cells(cZ_UEB, sp).Value
  ws.Cells(cZ_UEB, sp).Font.Bold = wsq.Cells(cZ_UEB, sp).Font.Bold
 Next
 zz = cZ_UEB->augenblickliche Zeile auf Bericht
 
->Aus Blättern relevante zeilen kopieren
 For x = LBound(QuellBlaetter) To UBound(QuellBlaetter)
  Set wsq = ThisWorkbook.Worksheets(QuellBlaetter(x))
  lRows = wsq.UsedRange.Row + wsq.UsedRange.Rows.Count - 1-> Anzahl benutzte Zeilen
  If lRows >= cZ_AB Then
   
  ->relevante Zeilen suchen
   Set r = wsq.Range(wsq.Cells(cZ_AB, cSP_K), wsq.Cells(lRows, cSP_K))
   
   Set Zelle = r.Find( _
    What:=cSP_K_TXT, _
    After:=ws.Cells(lRows, cSP_K), _
    LookIn:=xlValues, _
    LookAt:=xlWhole)
    
   If Not Zelle Is Nothing Then
    ersterFundort = Zelle.Address
    Do
     If wsq.Cells(Zelle.Row, cSP_N).Value = cSP_N_TXT Then
     ->Werte der Zeile auf Berichtsblatt übertragen
      wsq.Range(wsq.Cells(Zelle.Row, 1), wsq.Cells(Zelle.Row, lCols)).Copy
      zz = zz + 1
      ws.Activate
      ws.Cells(zz, 1).Select
      Selection.PasteSpecial Paste:=xlPasteValues
     End If
     Set Zelle = r.FindNext(Zelle)
    Loop While Not Zelle Is Nothing And Zelle.Address <> ersterFundort
    
   End If
  End If
  Application.CutCopyMode = False
  wsq.Activate
  wsq.Range(A1).Select
 Next
 ws.Activate
 ws.Range(A1).Select
 
 Application.ScreenUpdating = True

AUFRAEUMEN:
 Set ws = Nothing: Set wsq = Nothing: Set Zelle = Nothing: Set r = Nothing
End Sub

Private Sub Workbook_Open()
 Call BlattErstellenMitKgleichEundNgleichxAufBlatt1Und2
End Sub