Sicherung von mehreren WB und gewissen Bereichen

[peacescorer]

Hallo liebe Excel-Freunde

Ich habe ein Problem und hoffe, ihr könnt mir helfen...

Für eine etwas komplexere Bürolösung habe ich verschiedene Workbooks erstellt (Offerten, Rechnungen, etc.). Diese WB´s enthalten wiederum Sheets, von welchen ich einen bestimmten Bereich "sichern" will. (Der komplette Sheetexport ist keine Lösung für mich, da ich die ersten 8 Zeilen verschiedene Objekte, Grafiken, etc. habe und zudem jede Menge VBA-Codes...)

Das Gute: Der Bereich in den Sheets ist mit ("A9:PP" &lnglastrow) bis auf die unterschiedlichen lnglastrow immer identisch...
Das Schlechte: Ich weiß nicht mal im Ansatz, wie ich untenstehenden Code abändern muss, damit ich eine komplette Sicherung erstellen kann...

Die Wkb + Wks-Struktur: (Das erste sind die Wkb´s, der Einzug die Wks)

JB Modul 1 Offerten.xlsm
         Offerten
         Absagen
         Interner Bereich

JB Modul 2 Aufträge[b].xlsm[/b]
         Aufträge
         Akonto
         SR_Pauschal
         SR_GemOfferte
         Regierechnung
         Interner Bereich

JB Modul 5 Rechnungsübersicht[b].xlsm[/b]
        Rechnungsübersicht
        BezahlteRechnungen


Am liebsten wäre mir, wenn die Prozedur von jedem Workbook eine eigene Sicherungsdatei anlegt in welchem dann die jeweiligen Sheets und deren Bereiche gespeichert sind. D.h. z.B. die Sicherung von "JB Modul 1 Offerten" hat dann 3 Sheets mit den Bereichswerten des Originals. Der Vollständigkeit halber halte ich fest, dass ich auch mit .txt und .csv experimentiert habe... - das Trennzeichen (z.B. Semikolon) macht mir hier Kopfzerbrechen, da dieses Zeichen genauso wie der Beistrich relativ oft vorkommen. Von einer professionellen Datenbank-Lösung (Access) möchte ich ebenfalls absehen, da mir da das notwendige Wissen komplett fehlt. 

Hat jemand eine Idee wie ich das realisieren könnte? Mein einziger Ansatz wäre, Wbk´s,  Sheets´s und Bereich als Argumente übergeben und das ganze per Schleife abarbeiten... Diese Prozedur dann in einem separaten Workbook auszuführen. Aber leider ist mein VBA-Wissen (immer noch) zu rudimentär um dies umzusetzen...
 
Hier stehe ich derzeit: Untenstehender Code kopiert die Werte des angegebenen Bereiches meines Origingals in eine neues Wkb... aber eben nur das erste Sheet "Offerten".

Code:

Sub Datensicherung()
Dim wbQuelle        As Workbook
Dim wksQuelle       As Worksheet
Dim wbZiel          As Workbook
Dim wksZiel         As Worksheet
Dim strPfadZiel     As String
Dim lnglastrow      As Long
Dim strFileQuelle   As String
Dim iFileOpen%      'Argument für Funktion, ob Quelle verfügbar

'Abfrage ob wirklich speichern:
If MsgBox("Möchten Sie eine komplette Datensicherung erstellen?", vbQuestion + vbOKCancel, _
"Datensicherung") = vbCancel Then GoTo Fehler

On Error GoTo Fehler

'Beschleunigen:
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
   
   '********QUELLE**********
   strFileQuelle = ThisWorkbook.Path & "\" & "JB Modul 1 Offerten.xlsm"
   
   'Quelle verfügbar?
   iFileOpen = FileOpen(strFileQuelle) '(Sep.Funktion)
   Select Case iFileOpen
   Case 0
       'MsgBox "Verfügbar! Es kann weiter gehen!"
   Case 1
       MsgBox "Die Quelldatei wird von einem Benutzer verwendet! Bitte schliessen und Sicherung nochmals starten!"
       Exit Sub
   Case 2
       MsgBox "Die Quelldatei wurde verschoben bzw. konnte nicht gefunden werden!" & vbNewLine & "Bitte Pfad kontrollieren! Die Quelldatei muss im selben Verzeichnis wie das COCKPIT gespeichert sein."
       Exit Sub
   End Select
       
           'Wenn verfügbar --> Quelle öffnen und Quellsheet definieren:
           Set wbQuelle = Workbooks.Open(strFileQuelle)
           Set wksQuelle = wbQuelle.Worksheets("Offerten")
           
                   'Letzte Zeile in Quellsheet ermitteln (Für späteren Kopiervorgang):
                   With wksQuelle
                   lnglastrow = .Range("A65536").End(xlUp).Row
                   End With
   
   '***********ZIEL***********
   strPfadZiel = ThisWorkbook.Path & "\Database\Backup\" 'Zielpfad
   Set wbZiel = Workbooks.Add 'Neues Workbook
   wbZiel.SaveAs strPfadZiel & "Offert_Sicherung - " & Format(Now, "ddmmyy_hhmm") & ".xlsx" 'Speichern
   wbZiel.Worksheets.Add.Name = "Offert_Sicherung" 'Neues Sheet
   wbZiel.Worksheets("Tabelle1").Delete 'Überflüssiges Sheet löschen
   Set wksZiel = wbZiel.Worksheets("Offert_Sicherung") 'Zielsheet definieren

   '****KOPIERVORGANG****:
   With wksZiel
   wksQuelle.Range(wksQuelle.Cells(9, 1), wksQuelle.Cells(lnglastrow, 15)).Copy 'A9 bis
   .Range("A9").PasteSpecial (xlValues)
   End With
   
   '****QUELLE und ZIEL schliessen****:
   Application.CutCopyMode = False
   wbZiel.Close savechanges:=True
   wbQuelle.Close savechanges:=False

   MsgBox "Sicherung wurde erfolgreich angelegt!"

   'FEHLERTEUFEL:
Fehler:
   Application.ScreenUpdating = True
   With Err
   Select Case .Number
   Case 0 'Alles OK
   Case Else
   MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
   End Select
   End With
 
   'Beschleunigung ausschalten:
   With Application
   .ScreenUpdating = True
   .EnableEvents = True
   .Calculation = xlCalculationAutomatic
   .DisplayAlerts = True
   End With
 
   'Bereinigen:
   Set wbZiel = Nothing: Set wksZiel = Nothing
   Set wbQuelle = Nothing: Set wksQuelle = Nothing
End Sub


'PRÜFUNG, OB DATEI GEÖFFNET IST: (w/Firmennetzwerk)
Function FileOpen(sPath As String) As Integer
'nicht gefunden
If Dir(sPath) = "" Then
FileOpen = 2
'gefunden aber?
Else
   On Error GoTo errorhandler
   'Fehler bei Write wenn schon geöffnet
   'kommt nicht bei schreibgeschützter Datei
   Open sPath For Random Access Read Lock Read Write As #1
   Close #1
End If
Exit Function
errorhandler:
'Fehler 70 = File offen
If Err = 70 Then FileOpen = 1
End Function

[EbyAS]

Hallo,
also so ganz versteht man Deine Zeilen nicht.
 

Der komplette Sheet Export ist keine Lösung für mich, da ich die ersten 8 Zeilen verschiedene Objekte, Grafiken, etc. habe und zudem jede Menge VBA-Codes...)

Der Code den Du hochgeladen hast macht aber genau das (ein File).
 
Also entweder Du kopierst jedes Sheet, dazu aber brauchst Du jedoch kein Excel, dafür existieren bessere Tools.
 Oder Du speicherst nur die Daten.
Das habe ich auch schon nur mit csv-Dateien realisiert, da der Auftrag die Bedingung hatte, keine Datenbank.
Aber dazu sind natürlich wesentlich mehr Informationen erforderlich.

[peacescorer]

Hallo Armin

Danke für die Rückmeldung!

Hmm, kann dir nicht folgen bzw muss dir widersprechen... In meinem dzt. Code wird nicht das Sheet exportiert, sondern - so wie ich es möchte - die Werte eines Teilbereiches (...und das ganze möchte ich aber 3 x für alle 3 Sheets im ersten Wkb... und dann gleiches nochmals für die anderen Wkb´s, wobei hier der Name der Sicherungsdatei dann "Aufträge..." bzw. "Rechnungsübersicht..." ist...

Oder versteh ich dich nicht...?

Gruß Christian

Edit: Hab mir mein Posting nochmals angeschaut - war vielleicht etwas verwirrend, weil im Code die Sheet-Namen identisch sind mit der Quelle (was aber gewollt ist).
Was ich meinte, ich möchte nicht die "worksheet.copy"-Methode, das es mir hier das komplette Sheet kopiert. Ich möchte jedoch nur den Teilbereich als Werte kopieren.

Zusammenfassung:
Aus dem Quell-Workbook soll bei den erwähnten 3 Sheets die Teilbereiche ab A9 in ein neues Workbook kopiert werden. Das neue Workbook hat dann die gleichen 3 Sheets, aber nur die Werte, welche als Sicherungskopie dienen...

Soll ich die gegenständlichen Dateien nachstellen und hier hochladen?

[EbyAS]

Hallo Christian,
ja das wäre gut.

[schauan]

Hallöchen,

zuerst einmal zum Punkt "extra Workbook". Der Code passt da ja schon, da Du sowohl die Quelle als auch das Ziel im Code öffnest. Du müsstest nur prüfen, ob an allen Stellen auf das jeweils richtige Workbook zugegriffen wird - nicht, dass da irgendwo eine Zuweisung fehlt.

Bei Schleifen könntest Du überlegen, ob Du alles mit Schleifen realisierst oder eine Kombination aus Sub- Aufruf mit Parameterübergabe und Schleife für die Blätter.

Das mit dem Sub könnte im Prinzip so aussehen:

Code:

Private Sub Main()
Call Datensicherung "erste Datei"
Call Datensicherung "zweite Datei"
Call Datensicherung "dritte Datei"
End Sub

Sub Datensicherung(byval strDatei as String)
…

Im Sub Datensicherung verwendest Du dann die Variable je nach Inhalt z.B. so:

strFileQuelle = ThisWorkbook.Path & "\" & strDatei

Die Schleife kommt dann hier, statt:

Code:

Set wbQuelle = Workbooks.Open(strFileQuelle)
           Set wksQuelle = wbQuelle.Worksheets("Offerten")

dann z.B. so:

Code:

Set wbQuelle = Workbooks.Open(strFileQuelle)
For Each Blaetter in  wbQuelle.Sheets()          
Set wksQuelle = Blaetter

und weiter unten dann das zur Schleife gehörende Next.

Allerdings musst Du den Teil mit der Erzeugung des neuen Workbook vor die Schleife setzen, das wäre dieser Code:
(Das Löschen von Tabelle1 kommentierst Du aus bzw. setzt es hinter das Next)

Code:

'***********ZIEL***********
   strPfadZiel = ThisWorkbook.Path & "\Database\Backup\" 'Zielpfad
   Set wbZiel = Workbooks.Add 'Neues Workbook
   wbZiel.SaveAs strPfadZiel & "Offert_Sicherung - " & Format(Now, "ddmmyy_hhmm") & ".xlsx" 'Speichern
   'wbZiel.Worksheets("Tabelle1").Delete 'Überflüssiges Sheet löschen

Dies Zeilen bleiben in der Schleife:
wbZiel.Worksheets.Add.Name = "Offert_Sicherung" 'Neues Sheet
Set wksZiel = wbZiel.Worksheets("Offert_Sicherung") 'Zielsheet definieren

Allerdings mit einer kleinen Änderung:
wbZiel.Worksheets.Add.Name = Blaetter.Name 'Neues Sheet
Set wksZiel = wbZiel.Worksheets(Blaetter.Name) 'Zielsheet definieren