Sub Copy_file()
Dim Dlg As FileDialog
Dim WBQuelle1 As Workbook, WBQuelle2 As Workbook
Dim WBZiel As Workbook, TB3 As Worksheet, TB4 As Worksheet
Dim Pfad As String, NeuPfad, Neuname As String
Set WBQuelle1 = Workbooks("Quelle1.xlsx")
Set TB3 = WBQuelle1.Sheets("3")
Set TB4 = WBQuelle1.Sheets("4")
Pfad = "E:\temp\"
Set WBQuelle2 = Workbooks.Open(Pfad & "Quelle2.xlsx")
Neuname = "NeueDatei.xlsx"
Application.ScreenUpdating = False
TB3.Copy
Set WBZiel = ActiveWorkbook
ActiveSheet.Name = "Aktiva_ALT"
TB4.Copy after:=WBZiel.Sheets(Sheets.Count)
ActiveSheet.Name = "Passiva_ALT"
Set TB3 = WBQuelle2.Sheets("3")
Set TB4 = WBQuelle2.Sheets("4")
TB3.Copy after:=WBZiel.Sheets(Sheets.Count)
ActiveSheet.Name = "Aktiva_NEU"
TB4.Copy after:=WBZiel.Sheets(Sheets.Count)
ActiveSheet.Name = "Passiva_NEU"
Set Dlg = Application.FileDialog(msoFileDialogFolderPicker)
If Dlg.Show = True Then
NeuPfad = Dlg.SelectedItems(1) & "\"
WBZiel.SaveAs NeuPfad & Neuname
WBQuelle2.Close False
Else
MsgBox " Fehler"
Exit Sub
End If
End Sub