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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Ihr beiden, Danke für Eure Hilfe. Ich habe beide Sachen ausprobiert bei Hajo bekomme ich im Anschluss rote Schrift, und bei Nepumuk bekomme ich einen Laufzeitfehler 1004 Anwendung oder Objektdef. Fehler. Was mache ich falsch?. Könnt Ihr mir nochmal helfen.
Grüße Tim


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 strPath & Replace(ThisWorkbook.Name, "C:\Users\bossie\Desktop\Sicherung\.xlsm", "_" & Format(Now, "dd_mm_yyyy_hh.mm.ss") & ".xlsx"), xlOpenXMLWorkbook '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

Code: [Cc][+][-] Public Sub test() Dim wb As Workbook, ws As Worksheet, sh As Shape Dim strPath As String Application.ScreenUpdating = False 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 ws.UsedRange.Value = ws.UsedRange.Value For Each sh In ws.Shapes sh.Delete Next Next Do While wb.Connections.Count > 0 wb.Connections.Item(1).Delete Loop strPath = "C:\Users\bossie\Desktop\Sicherung\" Application.DisplayAlerts = False wb.Sheets("deleteMe").Delete wb.SaveAs strPath & Replace$(ThisWorkbook.Name, ".xlsm", "_" & _ Format$(Now, "dd_mm_yyyy_hh.mm.ss") & ".xlsx"), xlOpenXMLWorkbook Application.DisplayAlerts = True wb.Close False Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread