AW: Tabellen in neue Datei kopieren
26.03.2007 20:57:00
fcs
Hallo Fritz,
etwas Gehirnjogging am Abend kann nicht schaden, da ich ich mich mal an deine Aufgabenstellung gemacht.
Den Code im VBA-Editor in ein Modul kopieren.
Der Code löscht nach dem kopieren den kompletten Code in den Blättern der Sicherungskopie!
Gruß
Franz
Sub Sicherung()
'Kopieren der Blätter in der Liste im Blatt Daten in eine Sicherungsdatei
Dim wbZiel As Workbook, strZiel As String, wksZiel As Worksheet
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim wksDaten As Worksheet, rngBlatt As Range, rngGesichert As Range
Dim boNeu As Boolean, i As Long
Set wbQuelle = ThisWorkbook
Set wksDaten = wbQuelle.Worksheets("Daten")
Set rngBlatt = wksDaten.Range("A2:A51")
Set rngGesichert = wksDaten.Range("N2:N51")
'Verzeichnis und Dateiname für Sicherrung ermitteln
If UCase(wksDaten.Range("M1")) = "X" Then
strZiel = wksDaten.Range("N1") & "\" _
& Left(wbQuelle.Name, Len(wbQuelle.Name) - 4) & "-E.xls"
Else
strZiel = wbQuelle.Path & "\" _
& Left(wbQuelle.Name, Len(wbQuelle.Name) - 4) & "-E.xls"
End If
'Prüfen, on die Sicherungsdatei schon existiert
If Dir(strZiel) "" Then
'Sicherungsdatei öffnen
Set wbZiel = Workbooks.Open(FileName:=strZiel)
Else
'neue Datei mit einem Blatt anlegen und Datei speichern
Set wbZiel = Workbooks.Add(Template:=xlWBATWorksheet)
boNeu = True
wbZiel.SaveAs FileName:=strZiel
End If
'Blätter in Liste in Sicherungsdatei kopieren
For i = 1 To rngBlatt.Rows.Count
If rngBlatt(i, 1) "" And Not UCase(rngGesichert(i, 1)) = "X" Then
'püfen ob Blatt in Quelle vorhanden
For Each wksQuelle In wbQuelle.Worksheets
If wksQuelle.Name = rngBlatt(i, 1) Then
Exit For
End If
Next
If wksQuelle Is Nothing Then
MsgBox "Das Blatt mit dem Namen " & rngBlatt(i, 1) & " existiert nicht!"
Else
'püfen ob Blatt in Zieldatei vorhanden
For Each wksZiel In wbZiel.Worksheets
If wksZiel.Name = rngBlatt(i, 1) Then
Exit For
End If
Next
If wksZiel Is Nothing Then
' Blatt kopieren und Sicherung in Spalte N markieren
wksQuelle.Copy After:=wbZiel.Sheets(wbZiel.Sheets.Count)
rngGesichert(i, 1) = "X"
Else
If MsgBox("Das Blatt " & rngBlatt(i, 1) & " existiert in der Zieldatei bereits!" _
& vbLf & vbLf & "Soll das Blatt in der Zieldatei ersetzt werden?", _
vbYesNo + vbQuestion, "Blatt-Sicherung") = vbYes Then
Application.DisplayAlerts = False
wksZiel.Delete 'vorhandenne Blatt löschen
Application.DisplayAlerts = True
' Blatt kopieren
wksQuelle.Copy After:=wbZiel.Sheets(wbZiel.Sheets.Count)
End If
rngGesichert(i, 1) = "X"
End If
End If
End If
Next
If boNeu = True And wbZiel.Sheets.Count > 1 Then
'Leeres 1. Blatt in der neuerstellten Zieldatei löschen
Application.DisplayAlerts = False
wbZiel.Sheets(1).Delete
Application.DisplayAlerts = True
End If
Call Loesche_Ereignisprozeduren(wbZiel) ' Löscht gesamten Code in den Tabellen
wbZiel.Save
wbQuelle.Activate
End Sub
Sub Loesche_Ereignisprozeduren(wb As Workbook)
'Löscht Ereignisprozeduren im Workbook:
For n = wb.VBProject.vbComponents.Count To 1 Step -1
For i = 1 To wb.VBProject.vbComponents(n).CodeModule.CountOfLines
If wb.VBProject.vbComponents(n).Type 1 _
And wb.VBProject.vbComponents(n).Type 3 Then _
wb.VBProject.vbComponents(n).CodeModule.DeleteLines 1
Next
Next
End Sub