Hallo Ralf,

so ich habe nochmal intensiv geschaut und zwei seperate Subs erstellt. 

Ab dieser Stelle tut sich das Makro immer ziemlich schwer und bricht manchmal ab.

'Filtern
    
For PD = 1 To 2
    If PD = 1 Then ORT = "*BLN*"
    If PD = 2 Then ORT = "*CS*"
    If PD = 3 Then ORT = "*NSZ*"
    If PD = 4 Then ORT = "*SWE*"
    If PD = 5 Then ORT = "*I.NP-O-F*"
    If PD = 6 Then ORT = "*I.NA-O-R*"
    letztezeile = Sheets("Aufschlüsselung").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 4
            
        '************************** TEMP 1**************************************************
            Dim Datum1 As String, Datum2 As String
            
            Datum1 = CStr(CLng(CDate(Split(Worksheets("Eingabe").Cells(5, 3).Text, "=")(1))))
            Datum2 = CStr(CLng(CDate(Split(Worksheets("Eingabe").Cells(5, 4).Text, "=")(1))))
            
            ThisWorkbook.Worksheets("V03").Activate
            
            Rows(1).AutoFilter Field:=3, Criteria1:= _
                ">=" & Datum1, Operator:=xlAnd, Criteria2:="<=" & Datum2
                
                
            
        'Nach Netzen filtern
        ThisWorkbook.Worksheets("V03").Activate
            ' ActiveSheet.Range("$A$1:$KW$725").AutoFilter Field:=13, Criteria1:=Array( _
                "SWE"), Operator:= _
                xlFilterValues
          
'        Selection.AutoFilter Field:=13, Criteria1:="*BLN*", Operator:=xlOr
        Selection.AutoFilter Field:=13, Criteria1:=ORT, Operator:=xlOr
        
        Worksheets("V03").Range("M1").AutoFilter Field:=16, VisibleDropDown:=False
        
        
        
        
        'Vorgabe für Aufschlüsselung
        
        Sheets("Aufschlüsselung").Select
            Cells.Select
            Selection.ClearContents
        Worksheets("Aufschlüsselung").Cells.Delete
        
        Range("B3:E3").Select
            ActiveCell.FormulaR1C1 = """Nein""-Rückmeldungen V03"
            Range("B5").Select
            ActiveCell.FormulaR1C1 = "PD " & ORT
            Range("C5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_1_1"
            Range("D5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_1_2"
            Range("E5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_1_3"
            Range("F5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_2_1"
            Range("G5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_2_2"
            Range("H5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_2_3"
            Range("I5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_2_4"
            Range("J5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_2_5"
            Range("K5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_3_1"
            Range("L5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_3_2"
            Range("M5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_3_3"
            Range("N5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_3_4"
            Range("O5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_3_5"
            Range("P5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_3_6"
            Range("Q5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_3_7"
            Range("R5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_3_8"
            Range("S5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_1"
            Range("T5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_2"
            Range("U5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_2_1"
            Range("V5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_3"
            Range("W5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_3_1"
            Range("X5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_3_2"
            Range("Y5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_3_3"
            Range("Z5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_4"
            Range("AA5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_4_1"
            Range("AB5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_4_2"
            Range("AC5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_4_3"
            Range("AD5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_4_4"
            Range("AE5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_4_5"
            Range("AF5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_5"
            Range("AG5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_5_1"
            Range("AH5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_5_2"
            Range("AI5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_5_3"
            Range("AJ5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_6_1"
            Range("AK5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_6_2"
            Range("AL5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_6_3"
            Range("AM5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_6_4"
            Range("AN5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_6_5"
            Range("AO5").Select
            ActiveCell.FormulaR1C1 = "bauko_3_4_6_6"
            Range("AP5").Select
            ActiveCell.FormulaR1C1 = "bauko_4_1"
            Range("AQ5").Select
            ActiveCell.FormulaR1C1 = "bauko_4_2"
            Range("AR5").Select
            ActiveCell.FormulaR1C1 = "bauko_4_3"
            Range("AS5").Select
            ActiveCell.FormulaR1C1 = "bauko_4_4"
            Range("AT5").Select
            ActiveCell.FormulaR1C1 = "bauko_4_5"
            Range("AU5").Select
            ActiveCell.FormulaR1C1 = "bauko_4_6"
            Range("AV5").Select
            ActiveCell.FormulaR1C1 = "bauko_5_1"
            Range("AW5").Select
        
        
        
        'ID finden und kopieren
        
        Dim Zeilennr As Integer
        Dim Spaltennr As Integer
        Dim ID As String
        Dim maxZeilen As Integer
        Dim maxSpalten As Integer
        'Dim AktZeilennr as Integer
        
        Sheets("TEMP1").Select
            Cells.Select
            Selection.ClearContents
            
        Sheets("V03").Select
        Cells.Select
            Selection.Copy
            Sheets("TEMP1").Select
            Cells.Select
            ActiveSheet.Paste
        maxZeilen = Application.WorksheetFunction.CountA(Range("A:A"))
        
        For Zeilennr = 2 To maxZeilen
        
            For Spaltennr = 27 To 72
        
                If Cells(Zeilennr, Spaltennr) = "nein" Then
                    ID = Cells(Zeilennr, 1)
                    ' Max. Eintrag in 'Aufschlüsselung, Spalte xx ermitteln
                    Sheets("Aufschlüsselung").Select
                    AktZeilennr = ActiveSheet.Cells(1048576, (Spaltennr - 24)).End(xlUp).Row + 1
                    Sheets("Aufschlüsselung").Cells(AktZeilennr, Spaltennr - 24) = ID
                    Sheets("TEMP1").Select
                End If
        
            Next Spaltennr
        Next Zeilennr
        'Hier wird die letzte Zeile ermittelt
        'Egal in welcher Spalte sich die letzte Zeile befindet
        'Es werden alle Spalten geprüft und die letzte Zeile ausgegeben
        letztezeile = Sheets("Aufschlüsselung").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 4
        'letztezeile = Sheets("Aufschlüsselung").UsedRange.SpecialCells(xlCellTypeLastCell).Row
        
        '************************** TEMP 2**************************************************
            'Filtern
            
            Dim Datum3 As String, Datum4 As String
            
            Datum3 = CStr(CLng(CDate(Split(Worksheets("Eingabe").Cells(5, 3).Text, "=")(1))))
            Datum4 = CStr(CLng(CDate(Split(Worksheets("Eingabe").Cells(5, 4).Text, "=")(1))))
            
            ThisWorkbook.Worksheets("V03 erweitert").Activate
            
            Rows(1).AutoFilter Field:=3, Criteria1:= _
                ">=" & Datum1, Operator:=xlAnd, Criteria2:="<=" & Datum2
                
                
            
        'Nach Netzen filtern
        ThisWorkbook.Worksheets("V03 erweitert").Activate
            ' ActiveSheet.Range("$A$1:$KW$725").AutoFilter Field:=13, Criteria1:=Array( _
                "SWE"), Operator:= _
                xlFilterValues
        Selection.AutoFilter Field:=13, Criteria1:=ORT, Operator:=xlOr
        
        
        Sheets("Aufschlüsselung").Select
        Cells(letztezeile, 2) = """Nein""-Rückmeldungen V03 erw."
        Cells(letztezeile + 2, 2) = "PD " & ORT
        Cells(letztezeile + 2, 3) = "bauko_3_1_1"
        Cells(letztezeile + 2, 4) = "bauko_3_1_2"
        Cells(letztezeile + 2, 5) = "bauko_3_1_3"
        Cells(letztezeile + 2, 6) = "bauko_3_2_1"
        Cells(letztezeile + 2, 7) = "bauko_3_2_2"
        Cells(letztezeile + 2, 8) = "bauko_3_2_3"
        Cells(letztezeile + 2, 9) = "bauko_3_2_4"
        Cells(letztezeile + 2, 10) = "bauko_3_2_5"
        Cells(letztezeile + 2, 11) = "bauko_3_3_1"
        Cells(letztezeile + 2, 12) = "bauko_3_3_2"
        Cells(letztezeile + 2, 13) = "bauko_3_3_3"
        Cells(letztezeile + 2, 14) = "bauko_3_3_4"
        Cells(letztezeile + 2, 15) = "bauko_3_3_5"
        Cells(letztezeile + 2, 16) = "bauko_3_3_6"
        Cells(letztezeile + 2, 17) = "bauko_3_3_7"
        Cells(letztezeile + 2, 18) = "bauko_3_3_8"
        Cells(letztezeile + 2, 19) = "bauko_3_4_1"
        Cells(letztezeile + 2, 20) = "bauko_3_4_2"
        Cells(letztezeile + 2, 21) = "bauko_3_4_2_1"
        Cells(letztezeile + 2, 22) = "bauko_3_4_3"
        Cells(letztezeile + 2, 23) = "bauko_3_4_3_1"
        Cells(letztezeile + 2, 24) = "bauko_3_4_3_2"
        Cells(letztezeile + 2, 25) = "bauko_3_4_3_3"
        Cells(letztezeile + 2, 26) = "bauko_3_4_4"
        Cells(letztezeile + 2, 27) = "bauko_3_4_4_1"
        Cells(letztezeile + 2, 28) = "bauko_3_4_4_2"
        Cells(letztezeile + 2, 29) = "bauko_3_4_4_3"
        Cells(letztezeile + 2, 30) = "bauko_3_4_4_4"
        Cells(letztezeile + 2, 31) = "bauko_3_4_4_5"
        Cells(letztezeile + 2, 32) = "bauko_3_4_5"
        Cells(letztezeile + 2, 33) = "bauko_3_4_5_1"
        Cells(letztezeile + 2, 34) = "bauko_3_4_5_2"
        Cells(letztezeile + 2, 35) = "bauko_3_4_5_3"
        Cells(letztezeile + 2, 36) = "bauko_3_4_6_1"
        Cells(letztezeile + 2, 37) = "bauko_3_4_6_2"
        Cells(letztezeile + 2, 38) = "bauko_3_4_6_3"
        Cells(letztezeile + 2, 39) = "bauko_3_4_6_4"
        Cells(letztezeile + 2, 40) = "bauko_3_4_6_5"
        Cells(letztezeile + 2, 41) = "bauko_3_4_6_6"
        Cells(letztezeile + 2, 42) = "bauko_4_1"
        Cells(letztezeile + 2, 43) = "bauko_4_2"
        Cells(letztezeile + 2, 44) = "bauko_4_3"
        Cells(letztezeile + 2, 45) = "bauko_4_4"
        Cells(letztezeile + 2, 46) = "bauko_4_5"
        Cells(letztezeile + 2, 47) = "bauko_4_6"
        Cells(letztezeile + 2, 48) = "bauko_5_1"
        Cells(letztezeile + 2, 49) = "bauko_5_2"
        Cells(letztezeile + 2, 50) = "bauko_5_3"
        Cells(letztezeile + 2, 51) = "bauko_6_1"
        Cells(letztezeile + 2, 52) = "bauko_6_2"
        Cells(letztezeile + 2, 53) = "bauko_6_3"
        
        'ID finden und kopieren
        
        'Dim Zeilennr As Integer
        'Dim Spaltennr As Integer
        'Dim ID As String
        'Dim maxZeilen As Integer
        'Dim maxSpalten As Integer
        'Dim AktZeilennr as Integer
        
        Sheets("TEMP2").Select
            Cells.Select
            Selection.ClearContents
            
        Sheets("V03 erweitert").Select
        Cells.Select
            Selection.Copy
            Sheets("TEMP2").Select
            Cells.Select
            ActiveSheet.Paste
        maxZeilen = Application.WorksheetFunction.CountA(Range("A:A"))
        
        For Zeilennr = 2 To maxZeilen
        
            For Spaltennr = 26 To 76
        
                If Cells(Zeilennr, Spaltennr) = "nein" Then
                    ID = Cells(Zeilennr, 1)
                    ' Max. Eintrag in 'Aufschlüsselung, Spalte xx ermitteln
                    Sheets("Aufschlüsselung").Select
                    AktZeilennr = ActiveSheet.Cells(1048576, (Spaltennr - 23)).End(xlUp).Row + 1
                    Sheets("Aufschlüsselung").Cells(AktZeilennr, Spaltennr - 23) = ID
                    Sheets("TEMP2").Select
                End If
        
            Next Spaltennr
        Next Zeilennr
        'Hier wird die letzte Zeile ermittelt
        'Egal in welcher Spalte sich die letzte Zeile befindet
        'Es werden alle Spalten geprüft und die letzte Zeile ausgegeben
        letztezeile = Sheets("Aufschlüsselung").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 4
        
        '************************** TEMP 3**************************************************
            'Filtern
            
            Dim Datum5 As String, Datum6 As String
            
            Datum5 = CStr(CLng(CDate(Split(Worksheets("Eingabe").Cells(5, 3).Text, "=")(1))))
            Datum6 = CStr(CLng(CDate(Split(Worksheets("Eingabe").Cells(5, 4).Text, "=")(1))))
            
            ThisWorkbook.Worksheets("V0405").Activate
            
            Rows(1).AutoFilter Field:=3, Criteria1:= _
                ">=" & Datum1, Operator:=xlAnd, Criteria2:="<=" & Datum2
                
                
            
        'Nach Netzen filtern
        ThisWorkbook.Worksheets("V0405").Activate
            ' ActiveSheet.Range("$A$1:$KW$725").AutoFilter Field:=13, Criteria1:=Array( _
                "SWE"), Operator:= _
                xlFilterValues
        Selection.AutoFilter Field:=13, Criteria1:=ORT, Operator:=xlOr
        
        
        Sheets("Aufschlüsselung").Select
        Cells(letztezeile, 2) = """Nein""-Rückmeldungen V04 V05"
        Cells(letztezeile + 2, 2) = "PD " & ORT
        Cells(letztezeile + 2, 3) = "bauko_3_1"
        Cells(letztezeile + 2, 4) = "bauko_3_2"
        Cells(letztezeile + 2, 5) = "bauko_3_3"
        Cells(letztezeile + 2, 6) = "bauko_3_4_1"
        Cells(letztezeile + 2, 7) = "bauko_3_4_2"
        Cells(letztezeile + 2, 8) = "bauko_3_4_3"
        Cells(letztezeile + 2, 9) = "bauko_4_1"
        Cells(letztezeile + 2, 10) = "bauko_4_2"
        Cells(letztezeile + 2, 11) = "bauko_4_3"
        Cells(letztezeile + 2, 12) = "bauko_5_1"
        Cells(letztezeile + 2, 13) = "bauko_5_2"
        Cells(letztezeile + 2, 14) = "bauko_5_3"
        Cells(letztezeile + 2, 15) = "bauko_5_4"
        Cells(letztezeile + 2, 16) = "bauko_5_5"
        
        'ID finden und kopieren
        
        'Dim Zeilennr As Integer
        'Dim Spaltennr As Integer
        'Dim ID As String
        'Dim maxZeilen As Integer
        'Dim maxSpalten As Integer
        'Dim AktZeilennr as Integer
        
        Sheets("TEMP3").Select
            Cells.Select
            Selection.ClearContents
            
        Sheets("V0405").Select
        Cells.Select
            Selection.Copy
            Sheets("TEMP3").Select
            Cells.Select
            ActiveSheet.Paste
        maxZeilen = Application.WorksheetFunction.CountA(Range("A:A"))
        
        For Zeilennr = 2 To maxZeilen
        
            For Spaltennr = 24 To 37
        
                If Cells(Zeilennr, Spaltennr) = "nein" Then
                    ID = Cells(Zeilennr, 1)
                    ' Max. Eintrag in 'Aufschlüsselung, Spalte xx ermitteln
                    Sheets("Aufschlüsselung").Select
                    AktZeilennr = ActiveSheet.Cells(1048576, (Spaltennr - 21)).End(xlUp).Row + 1
                    Sheets("Aufschlüsselung").Cells(AktZeilennr, Spaltennr - 21) = ID
                    Sheets("TEMP3").Select
                End If
        
            Next Spaltennr
        Next Zeilennr
        'Hier wird die letzte Zeile ermittelt
        'Egal in welcher Spalte sich die letzte Zeile befindet
        'Es werden alle Spalten geprüft und die letzte Zeile ausgegeben
'        letztezeile = Sheets("Aufschlüsselung").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 4
Next PD

End Sub