AW: Das ist doch klar, ...
02.06.2007 22:48:00
Matthias
Hi Micha,
also, alles in "DieseArbeitsmappe" (der alte Code ist (leicht abgewandelt) mit dabei, also ersetzen:
Option Explicit
Const Blattname = "BE" ' b.B. anpassen
Private Sub KopieSpeichern()
Dim fn As String, i As Integer
On Error GoTo Fehler
'Dateinamen der Kopie ermitteln
fn = ThisWorkbook.Name
If UCase(Right(fn, 4)) = ".XLS" Then fn = Left(fn, Len(fn) - 4)
fn = ThisWorkbook.Path & "\Kopie-" & fn & "_ohne-BE.xls"
Application.EnableEvents = False
'Blätter in neue Mappe kopieren
ThisWorkbook.Worksheets.Copy
'keine Warnung beim Löschen des Blattes
Application.DisplayAlerts = False
'Blatt "BE" löschen (falls vorhanden)
On Error Resume Next
With ActiveWorkbook.Sheets(Blattname)
.Visible = True
.Delete
End With
On Error GoTo Fehler
'Code löschen
Code_loeschen
'Mappe sichern
With ActiveWorkbook
.SaveAs Filename:=fn
.Close
End With
Fehler:
Application.EnableEvents = True
Application.DisplayAlerts = True
If Err.Number > 0 Then MsgBox Err.Description, vbCritical, "Fehler " & Err.Number
End Sub
Private Sub Code_loeschen()
'Gesamten Code und Module löschen
'von K.Rola
Dim myVBComponents As Object
If ActiveWorkbook.Name = ThisWorkbook.Name Then Exit Sub
'sicherheits-check um nicht sich selbst zu löschen
With ActiveWorkbook.VBProject
For Each myVBComponents In .VBComponents
Select Case myVBComponents.Type
Case 1, 2, 3
.VBComponents.Remove .VBComponents(myVBComponents.Name)
Case 100
With myVBComponents.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next
End With
End Sub
Private Sub MappeSpeichern(Optional fn)
Dim vis As Long
Dim sh As Worksheet
On Error GoTo Fehler
Set sh = ActiveSheet
Application.ScreenUpdating = False
Application.EnableEvents = False
' ### Status merken: ###
vis = Worksheets(Blattname).Visible
' ### Blatt verstecken: ###
Worksheets(Blattname).Visible = xlSheetVeryHidden
If IsMissing(fn) Then
Application.StatusBar = "Speichert '" & ThisWorkbook.Name & "'..."
ThisWorkbook.Save
Else
Application.StatusBar = "Speichert '" & fn & "'..."
ThisWorkbook.SaveAs fn
End If
KopieSpeichern ' 0 Then MsgBox Err.Description, vbCritical, "Fehler " & Err.Number
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim aw
If Not ThisWorkbook.Saved Then
aw = MsgBox("Sollen ihre Änderungen in '" & ThisWorkbook.Name & "' gespeichert werden?", _
vbYesNoCancel + vbExclamation)
If aw = vbYes Then
MappeSpeichern
ElseIf aw = vbNo Then
ThisWorkbook.Saved = True
Else 'Abbrechen
Cancel = True
End If
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim fn
Cancel = True
If SaveAsUI Then
fn = Application.GetSaveAsFilename(ThisWorkbook.Name, "Excel-Dateien (*.xls), *.xls", , " _
Datei speichern")
If fn = False Then Exit Sub
MappeSpeichern fn
Else
MappeSpeichern
End If
End Sub
Gruß Matthias