anderen Ort speichern

Sub test()
Application.ScreenUpdating = False
Dim wb As Workbook, ws As Worksheet, sh As Shape
Set wb = Workbooks.Add(xlWBATWorksheet)
wb.Sheets(1).Name = "deleteMe"
For Each ws In ThisWorkbook.Worksheets
ws.Copy After:=wb.Sheets(wb.Sheets.Count)
Next
For Each ws In wb.Worksheets
UsedRange.Formula = UsedRange.Value
For Each sh In ws.Shapes
sh.Delete
Next
Next
Do While wb.Connections.Count > 0
wb.Connections.Item(1).Delete
Loop
Application.DisplayAlerts = False
wb.Sheets("deleteMe").Delete
wb.SaveAs Replace(ThisWorkbook.FullName, ".xlsm", "_" & Format(Now, "dd_mm_yyyy_hh.mm.ss") & ".xlsx"), xlOpenXMLWorkbook
Application.DisplayAlerts = True
wb.Close False
Application.ScreenUpdating = True
End Sub