Clever-Excel-Forum

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... Sad

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". Sad

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

Hallo,
also so ganz versteht man Deine Zeilen nicht.

Zitat: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.

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?

Hallo Christian,
ja das wäre gut.

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

peacescorer

EbyAS

peacescorer

EbyAS

schauan