Excel Datei in mehrere splitten und per mail versenden

Option Explicit
Sub Pivotrefresh()

    Worksheets("Pivot").Activate  
    ActiveSheet.PivotTables("PivotTable8").PivotCache.Refresh  
    
End Sub

Sub Start()

Dim I As Byte, K As Integer, X As Integer, Y As Integer
Dim Kriterium As String, Pfad As String
Dim AW As String

'Dies bitte anpassen => Pfad, wo gespeichert werden soll  
Pfad = "C:\"  

'Bildschirmaktualisierung abschalten  
Application.ScreenUpdating = False

'Datenbasis neu aufstellen  
Pivotrefresh

'Zum richtigen Tabellenblatt springen  
Worksheets("Quelle").Activate  

'Ende der Quelle finden  
Worksheets("Quelle").Cells(Rows.Count, 2).End(xlUp).Activate  
K = Replace(ActiveCell.Address(False, False), "B", "")  

'Beginn in Zeile => Pivottabelle  
I = 5

'Loslaufen  
Do

    'Ersten Eintrag der zu filternden Kriterien  
    Kriterium = Worksheets("Pivot").Cells(I, 1)  
      
    'Für jedes Kriterium ein Tabellenblatt  
    Worksheets.Add
    ActiveSheet.Name = Kriterium
    
    'Zunächst die Überschriften setzen  
    Worksheets(Kriterium).Cells(1, 1) = Worksheets("Quelle").Cells(1, 1)  
    Worksheets(Kriterium).Cells(1, 2) = Worksheets("Quelle").Cells(1, 2)  
    Worksheets(Kriterium).Cells(1, 3) = Worksheets("Quelle").Cells(1, 3)  
    Worksheets(Kriterium).Cells(1, 4) = Worksheets("Quelle").Cells(1, 4)  
    Worksheets(Kriterium).Cells(1, 5) = Worksheets("Quelle").Cells(1, 5)  
    Worksheets(Kriterium).Cells(1, 6) = Worksheets("Quelle").Cells(1, 6)  
    Worksheets(Kriterium).Cells(1, 7) = Worksheets("Quelle").Cells(1, 7)  
    Worksheets(Kriterium).Cells(1, 8) = Worksheets("Quelle").Cells(1, 8)  
    Worksheets(Kriterium).Cells(1, 9) = Worksheets("Quelle").Cells(1, 9)  
    Worksheets(Kriterium).Cells(1, 10) = Worksheets("Quelle").Cells(1, 10)  
    Worksheets(Kriterium).Cells(1, 11) = Worksheets("Quelle").Cells(1, 11)  
    Worksheets(Kriterium).Cells(1, 12) = Worksheets("Quelle").Cells(1, 12)  
    Worksheets(Kriterium).Cells(1, 13) = Worksheets("Quelle").Cells(1, 13)  
    Worksheets(Kriterium).Cells(1, 14) = Worksheets("Quelle").Cells(1, 14)  
    Worksheets(Kriterium).Cells(1, 15) = Worksheets("Quelle").Cells(1, 15)  
    Worksheets(Kriterium).Cells(1, 16) = Worksheets("Quelle").Cells(1, 16)  
    Worksheets(Kriterium).Cells(1, 17) = Worksheets("Quelle").Cells(1, 17)  
        
    'Zeile in jedem Tabellenblatt wieder auf zwei setzen  
    Y = 2
    
    'Die Quelle vom Anfang bis Ende durchlaufen  
    For X = 2 To K
      
        'Sofern Kriterium entspricht, kopieren  
        If Worksheets("Quelle").Cells(X, 2) = Kriterium Then  
            
            Worksheets(Kriterium).Cells(Y, 1) = Worksheets("Quelle").Cells(X, 1)  
            Worksheets(Kriterium).Cells(Y, 2) = Worksheets("Quelle").Cells(X, 2)  
            Worksheets(Kriterium).Cells(Y, 3) = Worksheets("Quelle").Cells(X, 3)  
            Worksheets(Kriterium).Cells(Y, 4) = Worksheets("Quelle").Cells(X, 4)  
            Worksheets(Kriterium).Cells(Y, 5) = Worksheets("Quelle").Cells(X, 5)  
            Worksheets(Kriterium).Cells(Y, 6) = Worksheets("Quelle").Cells(X, 6)  
            Worksheets(Kriterium).Cells(Y, 7) = Worksheets("Quelle").Cells(X, 7)  
            Worksheets(Kriterium).Cells(Y, 8) = Worksheets("Quelle").Cells(X, 8)  
            Worksheets(Kriterium).Cells(Y, 9) = Worksheets("Quelle").Cells(X, 9)  
            Worksheets(Kriterium).Cells(Y, 10) = Worksheets("Quelle").Cells(X, 10)  
            Worksheets(Kriterium).Cells(Y, 11) = Worksheets("Quelle").Cells(X, 11)  
            Worksheets(Kriterium).Cells(Y, 12) = Worksheets("Quelle").Cells(X, 12)  
            Worksheets(Kriterium).Cells(Y, 13) = Worksheets("Quelle").Cells(X, 13)  
            Worksheets(Kriterium).Cells(Y, 14) = Worksheets("Quelle").Cells(X, 14)  
            Worksheets(Kriterium).Cells(Y, 15) = Worksheets("Quelle").Cells(X, 15)  
            Worksheets(Kriterium).Cells(Y, 16) = Worksheets("Quelle").Cells(X, 16)  
            Worksheets(Kriterium).Cells(Y, 17) = Worksheets("Quelle").Cells(X, 17)  
            Y = Y + 1
            
        End If
        
    Next X
    
    'Neue Mappe aufmachen und Tabellenblatt verschieben  
    Sheets(Kriterium).Move
    ActiveWorkbook.SaveAs Filename:=Pfad & "\" & Kriterium & ".xls", FileFormat:= _  
        xlNormal, CreateBackup:=False
    
    'Aktives Tabellenblatt schließen. Änderungen wurden bereits gespeichert!  
    ActiveWorkbook.Close
    
    'Nächste Runde  
    I = I + 1
    
Loop Until Worksheets("Pivot").Cells(I, 1) = "Gesamtergebnis"  

AW = MsgBox("Der Vorgang wurde abgeschlossen!", vbOKOnly + vbInformation + vbSystemModal, "Hinweis")  

Application.ScreenUpdating = True

End Sub