Moin! Ist noch keine Lösung aber mal ein lesbarer Text: Hoffe mal das alles so in der Reihe ist, wie bei dir. So findet sich ggf. eher ien Helfer. VG

Hallo, ich möchte gerne 2 noch separate Makros zusammenführen und diese nacheinander laufen lassen. Könnt ihr mir hier behilflich sein.
1. Makro: Tabellenblatt wird nach einem Kriterium in einzelne Tabellenblätter gesplittet
2. Makro: Einzelne Tabellenblätter werden dann an einem Ort definierten Ort gespeichert Hier soll es jedoch dann so sein, dass die im ersten Makro erstellten Tabellenblätter nicht in der Datei als neue Tabellenblätter bleiben, sondern nach dem Speichern an dem definierten Ort wieder gelöscht werden. Über eure Info wäre ich euch sehr dankbar. Die beiden Makros sehen wie folgt aus:
1.

Option Explicit 
Sub KritToSheet() 
Dim objShSource As Worksheet, objSh As Worksheet 
Dim rng As Range, rngCopy As Range 
Dim varTemp As Variant 
Dim strFind As String, strFirst As String 
Dim lngLast As Long, lngAct As Long 
Dim rngCol As Range, intCol As Integer 

On Error Resume Next 
Set rngCol = Application.InputBox("Markieren Sie eine Zelle in der" & vbLf & _ "gewünschten Spalte! (Kriterium)", "Tabelle aufteilen", ActiveCell.Address, Type:=8) 

If rngCol Is Nothing Then Exit Sub 

intCol = rngCol(1).Column 
On Error GoTo ErrExit 
With Application 
	.ScreenUpdating = False 
	.EnableEvents = False 
	.DisplayAlerts = False 
	.Calculation = xlCalculationManual 
	.Cursor = xlWait 
End With 
rngCol.Parent.Copy After:=Sheets(Sheets.Count) 
Set objShSource = Sheets(Sheets.Count) 
With objShSource 
	lngLast = .Cells(Rows.Count, intCol).End(xlUp).Row 
	lngAct = lngLast 
	Do While lngAct > 1 
		strFind = .Cells(2, intCol) 
		Set rngCol = .Range(.Cells(2, intCol), .Cells(lngAct, intCol)) 
		Set rng = rngCol.Find(what:=strFind, lookat:=xlWhole) 

		If Not rng Is Nothing Then 
			strFirst = rng.Address 
			Do 
				If rngCopy Is Nothing Then 
					Set rngCopy = .Rows(rng.Row) 
				Else 
					Set rngCopy = Union(rngCopy, .Rows(rng.Row)) 
				End If 
				
				Set rng = rngCol.FindNext(rng) 
			Loop While Not rng Is Nothing And strFirst <> rng.Address 
		End If 
		
		If Not rngCopy Is Nothing Then 
			Set objSh = Worksheets.Add(After:=Sheets(Sheets.Count)) 
			On Error Resume Next 
			objSh.Name = strFind 
			If Err.Number <> 0 Then 
				objSh.Name = strFind & Format(Now, " hhmmss") 
				Err.Clear 
			End If 
		
			On Error GoTo ErrExit 
			rngCopy.Copy objSh.Cells(2, 1).PasteSpecial xlValues 
			objSh.Cells(2, 1).PasteSpecial xlFormats 
			Application.CutCopyMode = False 
			objShSource.Rows(1).Copy objSh.Rows(1) 
			rngCopy.Delete 
			Set rngCopy = Nothing 
			Set objSh = Nothing 
		End If 
		
		lngAct = .Cells(Rows.Count, intCol).End(xlUp).Row 
	Loop 
	.Delete 
End With 

ErrExit: 
Set objShSource = Nothing 
Set rngCol = Nothing 
With Application 
	.ScreenUpdating = True 
	.EnableEvents = True 
	.DisplayAlerts = True 
	.Calculation = xlCalculationAutomatic 
	.Cursor = xlDefault 
End With 

End Sub 

und das zweite makro

Sub alle_Tab_als_Datei() 
Dim neuname As String 
Dim pfad As String 
Dim i As Integer 

For i = 2 To ActiveWorkbook.Sheets.Count 
	neuname = Sheets("Upload").Range("A11") & " " & Sheets(i).Name 
	pfad = "C:\Users\xxx.xxx\Desktop\" 
	Sheets(i).Copy 
	ActiveWorkbook.SaveAs pfad & neuname 
	ActiveWorkbook.Close 
Next 
End Sub