AW: Tabellenblätter einzeln in variablen Pfad speicher
26.06.2015 21:19:46
da.ricci
Hallo Gerwin,
sorry, Fehlerteufel :- heisst natürlich nicht "ActiveSheet.Name" im Code, sonder, wie du richtig gemerkt hast "strDateiname"
>> wenn in dem Ausgewählten Zielordner die Datei bereits vorhanden ist ....
du könntest (spätestens) nach:
wsBlatt.Copy
ein:
Application.DisplayAlerts = False 'schaltet Fehlerüberprufüng aus
.....
und (frühestens) nach:
ActiveWorkbook.Close
ein:
Application.DisplayAlerts = True 'schaltet Fehlerüberprufüng wieder ein
.....
einfügen - dann würden schon vorhandene Dateien überschrieben werden.
Macht meist wenig Sinn bzw. ist selten erwünscht ;-)
Hier wäre es besser, den Dateinamen um eine "wirklich eindeutige" Variable zu erweitern
à la Cells(31, 9) oder Format(Now, "YYYYMMDD hh-mm-ss")
Problem ist das Excel so "sauschnell" ist dass, der Speichervorgang von einem Blatt bis nächsten Blatt nur ein "Zwinkern" dauert.
Da müsste man noch ein:
Application.Wait (Now + TimeValue("0:00:1")) ' warte 1 Sekunde
vor:
Next wsBlatt ' mache weiter
Eleganter wäre, statt Sekunden zu warten und zählen - à la "Windows-Funtion" den Dateinamen um (index) zu erweitern. (Dateiname.xlsx, Dateiname_1.xlsx, Dateiname_2xlsx, ....)
>> ... das Auswählen der Blätter auch ohne die Select Methode ......
Naja - du wolltest: 4 von 6 Blättern - die müßt du irgendwie auswählen. ;-)
Ich denke mal 2 Blätter Visible - nicht kopieren - 4 Blätter Hidden - kopieren
Dann ungefähr so
- Worksheet.xlSheetVisible wird nichr kopiert
- Fehler: Datei schon vorhanden wird mit - "Windows-Dubletten-Format" korrigiert:
Sub Tabellenblätter_einzeln_in_variablen_Pfad_speichern_vers2()
Dim Ordnerpfad As String, strDateiname As String, strPfad As String
Dim myDialog As Object, wsBlatt As Worksheet, BlattAuswahl As String, i As Integer
' == aktueller Pfad von Quelldatei
strPfad = ActiveWorkbook.Path & "\"
' == Speichername
strDateiname = Cells(53, 1) & " Gelangensbestätigung " & Cells(30, 9) & _
" " & Cells(31, 9) & " " & Format(Now, "yyyymmdd")
Set myDialog = Application.FileDialog(msoFileDialogFolderPicker)
With myDialog
.Title = "Speicherordner auswählen"
' == Vorgabe Speicherpfad
.InitialFileName = " %USERPROFILE%\My Documents\" ' == oder:"D:\" oder:"\\Netzlaufwerk\"
' == oder Vorgabe: aktueller Pfad von Quelldatei
' .InitialFileName = strPfad
If .Show = -1 Then
Ordnerpfad = .SelectedItems(1)
' MsgBox Ordnerpfad 'Zur Info
For Each wsBlatt In ThisWorkbook.Worksheets
Application.ScreenUpdating = False '== Bildschirm Aktualisierung abschalten
Application.DisplayAlerts = False '== Fehlermeldung abschalten
' MsgBox wsBlatt.Name & " XlSheetVisibility ist: " & wsBlatt.Visible 'Zur Info
If wsBlatt.Visible = xlSheetHidden Then
With wsBlatt
.Visible = xlSheetVisible
.Copy
If i = 0 Then ' == "normaler" Speichername
ActiveWorkbook.SaveAs Filename:=Ordnerpfad & "\" & strDateiname, _
FileFormat:=xlOpenXMLWorkbook ' = .xlsx
Else ' == i > 0 Speichername im "Windows-Dubletten-Format": Dateiname_1.*
ActiveWorkbook.SaveAs Filename:=Ordnerpfad & "\" & strDateiname & "_" & i, _
FileFormat:=xlOpenXMLWorkbook ' = .xlsx
End If
ActiveWorkbook.Close
ThisWorkbook.Activate ' == QuellMappe von "Macro-Auftuf" aktivieren
.Visible = xlSheetHidden ' == und das Blatt wieder verstecken
i = i + 1
End With
ElseIf wsBlatt.Visible = xlSheetVeryHidden Then
With wsBlatt
.Visible = xlSheetVisible
.Copy
If i = 0 Then
ActiveWorkbook.SaveAs Filename:=Ordnerpfad & "\" & strDateiname, _
FileFormat:=xlOpenXMLWorkbook ' = .xlsx
Else
ActiveWorkbook.SaveAs Filename:=Ordnerpfad & "\" & strDateiname & "_" & i, _
FileFormat:=xlOpenXMLWorkbook ' = .xlsx
End If
ActiveWorkbook.Close
ThisWorkbook.Activate
.Visible = xlSheetVeryHidden
i = i + 1
End With
Else
'nichts
End If
Next wsBlatt
Application.ScreenUpdating = True ' == Bildschirm Aktualisierung einschalten
Application.DisplayAlerts = True ' == Fehlermeldung einschalten
End If
End With
End Sub
Wobei, bei nochmaligen Aufruf von Macro werden die Dateien, sehr wohl überschrieben.
Das würde sich nur über eine "Dir-Abfrage" lösen lassen - dafür hab ich im Moment keine Lösung ;-)
Aber siehe mal: https://www.herber.de/mailing/vb/html/vafctdir.htm
zur Info
(muss ich mich da auch erst einarbeiten)
Grüsse
da.ricci
schönes WE - muß mal "kurz" nach: http://www.vienna.at/specials/donauinselfest