Nur eingeblendeten Blätter ohne Code speichern
12.04.2008 11:04:00
Becker
Ich will nur eingeblendete Tabellen Blätter einer Mappe unter neue Mappe speicher aber ohne Makros Module und ohne Makros in "DieserArbeitsmappe" was soll verändert werden in unteren Code?
Den Code habe ich hier in Internet gefunden. Funktioniert super aber dabei werden die ausgeblendeten Tabellen Blätter mitgespeichert.
****************************************************************
Sub backup_ohne_code()
Dim i, a, abfrage, anzseiten, zaehler As Integer
Dim bisher As Byte
Dim rest, SummeRunden, start, diff As Date
Dim wb1, wb2 As Workbook
Dim ws1, ws2 As Worksheet
Set wb1 = ThisWorkbook
abfrage = MsgBox("Wollen Sie jetzt ein Backup erstellen?", vbYesNo + vbQuestion)
If abfrage = vbNo Then
Application.ScreenUpdating = True
Exit Sub
End If
Application.ScreenUpdating = False
Workbooks.Add
Set wb2 = ActiveWorkbook
Sheets.Add
ActiveSheet.Move before:=Worksheets(1)
Set ws2 = wb2.Sheets(1) 'leerblatt am Schluß löschen
a = wb2.Sheets.Count
While a > 1
Application.DisplayAlerts = False
Sheets(2).Delete
Application.DisplayAlerts = True
a = wb2.Sheets.Count
Wend
start = Now
anzseiten = wb1.Sheets.Count
zaehler = 0
For i = 1 To wb1.Sheets.Count
a = wb2.Worksheets.Count
wb2.Sheets.Add
wb2.ActiveSheet.Name = wb1.Sheets(i).Name
Set ws1 = ActiveSheet
wb1.Sheets(i).Cells.Copy
ws1.Paste
zaehler = zaehler + 1
bisher = (zaehler) * 100 / anzseiten
SummeRunden = Now
diff = SummeRunden - start
rest = anzseiten * diff / zaehler - diff
Application.StatusBar = "Bisher: " & bisher & "% - aktuell " _
& zaehler & " von " & anzseiten & " - Restzeit: ca. " & rest
Next i
Application.StatusBar = "Bitte noch etwas Geduld für das Speichern und Beenden!"
Application.DisplayAlerts = False
ws2.Delete
Application.DisplayAlerts = True
On Error GoTo speichern
Workbooks.Open Filename:=wb1.Path & "\Backup_" & Date & ".xls"
On Error GoTo 0
ActiveWindow.Close
abfrage = MsgBox("Eine Datei mit dem Namen " & Chr(13) & _
"Backup_" & Date & ".xls" & Chr(13) & _
"existiert bereits in " & Chr(13) & _
wb1.Path & " ." & Chr(13) & "Wollen Sie diese Datei überschreiben?" _
, vbYesNo + vbCritical)
If abfrage = vbNo Then
wb2.Close savechanges:=False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "Die Datei wurde nicht gespeichert."
Else
Kill wb1.Path & "\Backup_" & Date & ".xls"
wb2.SaveAs "Backup_" & Date & ".xls"
wb2.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "Die Datei wurde unter " & Chr(13) & wb1.Path & "\Backup_" & Date & ".xls" & Chr(13) & _
"gespeichert."
End If
Exit Sub
speichern:
wb2.SaveAs wb1.Path & "\Backup_" & Date & ".xls"
wb2.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "Die Datei wurde unter " & Chr(13) & wb1.Path & "\Backup_" & Date & ".xls" & Chr(13) & _
"gespeichert."
End Sub
********************************************************************
Leider sind meine Kenntnisse in VBA noch begrenzt, wäre super, wenn mir jemand helfen könnte, der sich damit auskennt.
Ich Danke Euch für Euer Mühen
Freue mich über jeden Hinweis!
Netten Gruß
Becker
XP Pro, Office 2007