Sicherheitskopie ohne Makros, Before Close

Sub KopieListe_generieren() Dim MyPath As String, UhrZeit As String Dim OriginalLagerD As Workbook, SelgerLagerD As Workbook Dim OriginalLagerS As Worksheet, SelgerLagerS As Worksheet Dim i As Integer, j As Integer, LastRowLager As Integer Application.DisplayAlerts = False MyPath = ThisWorkbook.Path ' Lege Sicherheitskopie der Lagerliste (=diese Datei) an UhrZeit = ThisWorkbook.Sheets("Lager").Cells(1, 1) ThisWorkbook.SaveAs Filename:=MyPath & "\Lagerliste_Aktionsarchiv\" & "Lagerliste " & Date & _ _ " " & UhrZeit & ".xls" ThisWorkbook.SaveAs Filename:=MyPath & "\Lagerliste_2009.xls" Workbooks(Workbooks.Count).Close savechanges:=True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Florian,
versuche es mal mit diesem Code.
Gruß Odje

Option Explicit


Private Sub CommandButton1_Click()
Dim intIndex As Integer
Dim blnFound As Boolean
Dim strRef   As String
blnFound = False
strRef = "Microsoft Visual Basic for Applications Extensibility"
With ThisWorkbook.VBProject.References
For intIndex = 1 To .Count
Debug.Print .Item(intIndex).Description, .Item(intIndex).GUID
If Left(.Item(intIndex).Description, Len(strRef)) = strRef Then
If .Item(intIndex).IsBroken Then
.Remove (.Item(intIndex))
Else
blnFound = True
End If
Exit For
End If
Next intIndex
If Not blnFound Then
Call Application.VBE.ActiveVBProject.References.AddFromGuid("{0002E157-0000-0000-C000-  _
_
000000000046}", 5, 3)
End If
End With
Dim sFilename As String, Pfad
Application.ScreenUpdating = False
Pfad = "d:\datensicherung"
sFilename = Pfad & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & _
Format(Now, "_DD.MM.YYYY_hhmm") '& ".xls"
ThisWorkbook.SaveCopyAs Filename:=sFilename
Call CodeEntfernen(sFilename)
Call CommandButtonEntfernen(sFilename)
Call CommentsEntfernen(sFilename)
End Sub

'*********************************************************************************


Private Function CodeEntfernen(sFilename As String)
Dim Wb As Workbook, VBComp As VBComponent
Dim x As Long
Set Wb = Workbooks.Open(Filename:=sFilename)
For x = Wb.VBProject.VBComponents.Count To 1 Step -1
Set VBComp = Wb.VBProject.VBComponents(x)
If VBComp.Type = vbext_ct_StdModule Or _
VBComp.Type = vbext_ct_ClassModule Or _
VBComp.Type = vbext_ct_MSForm Then
Wb.VBProject.VBComponents.Remove VBComp
ElseIf VBComp.Type = vbext_ct_Document Then
'DieseArbeitsmappe und Tabellenblätter
VBComp.CodeModule.DeleteLines 1, VBComp.CodeModule.CountOfLines
End If
Next
Wb.Close SaveChanges:=True
AUFRAEUMEN:
Set Wb = Nothing: Set VBComp = Nothing
End Function

'*********************************************************************************


Private Function CommandButtonEntfernen(sFilename As String)
Dim Wb As Workbook, ws As Worksheet
Dim x As Long
Set Wb = Workbooks.Open(Filename:=sFilename)
For Each ws In Wb.Worksheets
For x = ws.OLEObjects.Count To 1 Step -1
If ws.OLEObjects(x).progID = "Forms.CommandButton.1" Then
ws.OLEObjects(x).Delete
End If
Next
Next
Wb.Close SaveChanges:=True
AUFRAEUMEN:
Set Wb = Nothing: Set ws = Nothing
End Function

'*********************************************************************************


Private Function CommentsEntfernen(sFilename As String)
Dim Wb As Workbook, ws As Worksheet
Dim x As Long
Set Wb = Workbooks.Open(Filename:=sFilename)
For Each ws In Wb.Worksheets
ws.UsedRange.ClearComments
Next
Wb.Close SaveChanges:=True
Application.ScreenUpdating = True
AUFRAEUMEN:
Set Wb = Nothing: Set ws = Nothing
End Function

Beliebteste Forumthreads (12 Monate)

Sicherheitskopie ohne Makros, Before Close

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Sicherheitskopie ohne Makros, Before Close

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread