Option Explicit
Sub ZeilenAusblenden()
Dim wbZiel As Workbook, wsZiel As Worksheet
Dim ws As Worksheet, i As Long, raBereich As Range
Application.ScreenUpdating = False
Set wbZiel = Workbooks.Open("C:\Users\Sors\Desktop\Sors Projekt\Testbericht.xlsm")
Set wsZiel = wbZiel.Worksheets("Tests bestanden")
For Each ws In ThisWorkbook.Worksheets
With ws
For i = 1 To .Cells(.Rows.Count, "H").End(xlUp).Row
If UCase(.Cells(i, "H")) = "X" Then
If raBereich Is Nothing Then
Set raBereich = .Cells(i, "H")
Else
Set raBereich = Union(raBereich, .Cells(i, "H"))
End If
End If
Next i
If Not raBereich Is Nothing Then
raBereich.EntireRow.Copy
With wsZiel
.Rows(.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row).PasteSpecial Paste:=xlPasteValues
End With
Set raBereich = Nothing
End If
End With
Next ws
Application.CutCopyMode = False
Set wbZiel = Nothing: Set wsZiel = Nothing: Set raBereich = Nothing
End Sub