Makro: Fehler abfangen + ergänzen

Question

Hallo VBA-Experten,
von der Seite vba.de von Alfons Seeberger habe ich das folgende Makro:
Sub Tabellen_in_neue_Dateien_kopieren()
'jede Tabelle dieser Datei als neue Datei speichern
'Dateiname ist jeweils der Tabellenname
Dim Pfad As String
Dim wks As Worksheet
Pfad = ThisWorkbook.Path & "\"
'prüfen ob Pfad existiert
If Dir(Pfad) = "" Then
MsgBox "Pfad existiert nicht", , "Abbruch"
Exit Sub
End If
On Error GoTo Fehler
Application.ScreenUpdating = False
'eventuell schon vorhandene Datei ohne Rückfrage überschreiben
Application.DisplayAlerts = False
For Each wks In ThisWorkbook.Worksheets
ThisWorkbook.Worksheets(wks.Name).Copy
ActiveWorkbook.SaveAs (Pfad & wks.Name)
ActiveWorkbook.Close
Next wks
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "alle Tabellen gespeichert in" & vbNewLine & vbNewLine _
& Pfad, , ""
Exit Sub
Fehler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub
Wenn eine Datei ausgeblendete Tabellen enthält, führt das zu "Laufzeitfehler 1004, die Copy-Methode...." an der unterstrichenen Stelle.
Wie muss ich das Makro ergänzen, damit alle sichtbarenTabellen kopiert werden, die Ausgeblendeten aber übersprungen werden?

Nach "ActiveWorkbook.SaveAs (Pfad & wks.Name)" würde ich gerne noch eine Unterbrechung? Abfrage? einbauen, wo entschieden werden kann, ob diese Datei gedruckt wird, per Email verschickt wird oder nichts weiter passiert.

mfg
vielen Dank im Voraus

Wolfgang

Answer 1

Zum ersten Punkt:

...
For Each wks In ThisWorkbook.Worksheets
If ThisWorkbook.Worksheets(wks.Name).Visible Then
ThisWorkbook.Worksheets(wks.Name).Copy
ActiveWorkbook.SaveAs (Pfad & wks.Name)
ActiveWorkbook.Close
End If
Next wks
...

Durch den IF ... End IF Teil werden nur sichtbare Blätter kopiert und gespeichert.

Das mit mit der Abfrage wird etwas umfangreicher... Habe im Moment leider nicht soviel Zeit. Evtl. melde ich mich nochmal oder vielleicht hat ja ein anderer Excel-Coder gerade Langeweile...

mfg, Massaraksch

Answer 2

Hallo,
der Link zum Ursprung des Makros war falsch, richtig ist:

">vba1.de/vba/060tabellen_speichern.php

Danke Massarakschich,
werde es morgen testen.

mfg

Wolfgang

Answer 3

Hallo Wolfgang,

zum 1. Teil hast Du ja bereits eine Antowrt von @Massaraksch bekommen. Der 2. Teil könnte z.B. wie in folgendem Beispielcode aussehen.

Teste das Makro aber bitte in einer Testdatei und nicht gleich in Deiner Originaldatei.

Dim intFrage As Integer

intFrage = MsgBox("Soll Tabelle gedruckt werden?", vbQuestion + vbYesNo, "Tabelle drucken?")

If intFrage = 6 Then
MsgBox "Anstelle der MessageBox den Code zum Drucken"
GoTo Weiter
End If

intFrage = MsgBox("Soll Tabelle per Mail versandt werden?", vbQuestion + vbYesNo, "Tabelle als E-Mail?")

If intFrage = 6 Then
MsgBox "Anstelle der MessageBox den Code zum Versenden der E-Mail"
GoTo Weiter
End If

Weiter:

MsgBox "Hier dann den restlichen VBA-Code, z.B. ActiveWorkbook.Close"

MfG,
Oliver
[sup]Jeder macht was er will, keiner macht was er soll, aber alle machen mit.[/sup]

Answer 4

Hallo Massaraksch und Oliver,

entschuldigt bitte, das ich so lange nicht geantwortet habe.
Ich hatte letzte Woche als Urlaubsvertretung in einer Außenstelle gearbeitet und dort keine Möglichkeit an dieser Aufgabe weiter zu arbeiten.
Eure Ergänzungen habe ich erst heute einfügen und testen können. Vielen Dank, das Makro funktioniert jetzt wie gewünscht.
Hier zeige ich eine Variante, in der der Dateiname auch das aktuelle Datum enthält. Nochmal Danke Oliver!

Sub Tab_Datei_Datum()
jede Tabelle dieser Datei als neue Datei speichern, Dateiname ist jeweils der Tabellenname
Dim Pfad As String
Dim wks As Worksheet
Pfad = ThisWorkbook.Path & "\"
'prüfen ob Pfad existiert
If Dir(Pfad) = "" Then
MsgBox "Pfad existiert nicht", , "Abbruch"
Exit Sub
End If
On Error GoTo Fehler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each wks In ThisWorkbook.Worksheets
If ThisWorkbook.Worksheets(wks.Name).Visible Then
ThisWorkbook.Worksheets(wks.Name).Copy
ActiveWorkbook.SaveAs (Pfad & wks.Name & " " & Format(Now, "dd.mm.yy") & ".xls")
'eventuell schon vorhandene Datei ohne Rückfrage überschreiben
Dim intFrage As Integer
intFrage = MsgBox("Soll Tabelle gedruckt werden?", vbQuestion + vbYesNo + vbDefaultButton2)
If intFrage = 6 Then
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End If

intFrage = MsgBox("Soll Tabelle per Mail versandt werden?", vbQuestion + vbYesNo + vbDefaultButton2)
If intFrage = 6 Then
Application.Dialogs(xlDialogSendMail).Show
End If
ActiveWorkbook.Close
End If
Next wks
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "alle Tabellen gespeichert in" & vbNewLine & vbNewLine _
& Pfad, , ""
Exit Sub
Fehler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler"
End Sub

mfg
Wolfgang