AW: Datei speichern
12.04.2023 23:25:12
Sheldon
Hallo Daniel,
als Ansatz dieser Code. Du musst natürlich alles anpassen an deine Datei, aber so sollte es funktionieren. Wichtig ist, dass es die Umgebungsvariable "OneDrive" gibt (sollte OneDrive immer anlegen), sowie dass es die Unterordner Logistik\02_Lieferdokumente bereits gibt. Wenn diese manuell erzeugt werden sollen, dann springe nur zum OneDrive-Ordner und lasse den Rest die User machen.
Sub Daniel()
Dim sFileName As String, oNewFile As Workbook, WorkbooksList As String
'#################################################
'### Speicherort und Dateiname wird festgelegt ###
'#################################################
'Annahme, dass der Zellwert für den Dateinamen in Zelle A1 auf Blatt "Invoice" steht. Ggf. auf deine Datei anpassen.
sFileName = Application.GetSaveAsFilename(InitialFileName:=Environ("OneDrive") & "\Logistik\02_Lieferdokumente\Rechnung " & Sheets("Invoice").Range("A1"), _
FileFilter:="Excel Dateien (*.xlsx), *.xlsx")
'#############################################################################
'### Blätter Invoice, Delivery, CMR und Tarifnummer in neue Datei kopieren ###
'#############################################################################
'Erstmal alle offenen Dateien in Variable WorkbooksList speichern
For Each oNewFile In Application.Workbooks
WorkbooksList = WorkbooksList & "|" & oNewFile.Name
Next
'nun Blatt "Invoice" in neue Arbeitsmappe kopieren
ThisWorkbook.Sheets("Invoice").Copy
'und jetzt die WorkbooksList mit allen offenen Dateien vergleichen, um die neu angelegte Datei als oNewFile festzulegen
For Each oNewFile In Application.Workbooks
'Wenn diese Datei nicht in der WorkbooksList steht, ist es die neu angelegte Datei. Dann mit Exit For die Schleife verlassen.
If InStr(1, WorkbooksList, oNewFile.Name, vbTextCompare) = 0 Then Exit For
Next
'nun alle anderen Tabellenblätter in die neue Datei kopieren, bis auf Invoice (ist ja schon da) und Fehlermeldung (soll ja nicht mit).
For Each oSheet In ThisWorkbook.Worksheets
If Not oSheet.Name = "Fehlermeldung" And Not oSheet.Name = "Invoice" Then
oSheet.Copy after:=oNewFile.Sheets(oNewFile.Sheets.Count)
End If
Next
'nun alle Formeln durch Werte ersetzen
For Each oSheet In oNewFile.Worksheets
oSheet.UsedRange.Copy
oSheet.UsedRange.PasteSpecial Paste:=xlPasteValues
Next
'###############################################################################################
'### Neu angelegte Datei am zuerst festgelegten Speicherort mit festgelegtem Namen speichern ###
'###############################################################################################
oNewFile.SaveAs Filename:=sFileName, FileFormat:=xlOpenXMLWorkbook
oNewFile.Close
'die Objekt-Variablen werden freigesetzt, um den Arbeitsspeicher freizugeben
Set oNewFile = Nothing
Set oSheet = Nothing
End Sub
Funktionierts?
Gruß
Sheldon