AW: Wert um eins erhöhen, dann die Datei speichern ?
23.10.2008 10:56:00
fcs
Hallo Selma,
hier die Anpassung.
Der Teilname des Dateinamens kann jetzt in einer Eingabebox eingegeben/modifiziert werden.
Die erstellte Kopie der Datei wird in der Subroutine nochmals geöffnet und der VBA-Code komplett gelöscht.
Damit das Löschen des Codes funktioniert muss du ggf. im Menü Extras--Optionen--Register "Sicherheit"--Makrosicherheit -- Register "vertrauenswürdige Herausgeber" die Option "Zugriff auf Visual Basic Project vertrauen" aktivieren. Diese Menüfolge gilt für Excel 2003, Excel 2000: ?
Alternativ könntest du das Makro auch in deiner persönlichen Makro-Arbeitsmappe in einem Modul speichern oder auch in einer anderen Datei, als in der Datei von der die Kopien erstellt werden. Dann ist in den Kopien auch kein Code enthalten.
Gruß
Franz
Sub aaTest()
Dim varEingabe, wks As Worksheet, wb As Workbook, intI As Integer
Dim strDateiName As String
Dim strTeilName As String
Set wb = ActiveWorkbook
Set wks = ActiveSheet
varEingabe = Application.InputBox(Prompt:="Teilnamen der Datei eingeben", _
Title:="Datei mit Serien-Nummer Speichern", _
Default:="Berechnungsblatt_UNI_", _
Type:=2)
If varEingabe = False Then
Exit Sub
Else
strTeilName = varEingabe
End If
varEingabe = Application.InputBox(Prompt:="Bitte den Startwert eingeben", _
Title:="Datei mit Serien-Nummer Speichern", _
Default:=wks.Range("C4") + 1, _
Type:=1)
If varEingabe = False Then Exit Sub
wks.Range("C4").Value = varEingabe
strDateiName = wb.Path & "\" & strTeilName & wks.Range("C4") & ".xls"
If VBA.Dir(strDateiName) "" Then
MsgBox "Datei " & strDateiName & " schon vorhanden!"
Else
wb.SaveCopyAs Filename:=strDateiName
Call Code_loeschen(strDateiName)
End If
varEingabe = Application.InputBox(Prompt:="Wie oft soll die Datei gespeichert werden?", _
Title:="Datei mit Serien-Nummern Speichern", _
Default:=0, _
Type:=1)
If varEingabe = False Then Exit Sub
For intI = 1 To varEingabe
wks.Range("C4").Value = wks.Range("C4").Value + 1
strDateiName = wb.Path & "\" & strTeilName & wks.Range("C4") & ".xls"
If VBA.Dir(strDateiName) "" Then
MsgBox "Datei " & strDateiName & " schon vorhanden!"
Else
wb.SaveCopyAs Filename:=strDateiName
Call Code_loeschen(strDateiName)
End If
Next
End Sub
Sub Code_loeschen(strDatei As String)
'Gesamten Code und Module in Datei löschen
Dim myVBComponents As Object, wb As Workbook
On Error GoTo Fehler
Application.ScreenUpdating = False
Set wb = Application.Workbooks.Open(Filename:=strDatei)
'Sicherheitsabfrage
'If MsgBox("Sämtlichen VBA-Code in Datei " & wb.FullName & " löschen?", _
vbYesNo, "VBA-Code löschen") = vbYes Then
'Sicherheits-check um nicht sich selbst zu löschen
If LCase(wb.Name) = LCase(ThisWorkbook.Name) Or _
LCase(wb.Name) = LCase("Personl.xls") Then
MsgBox "In der Arbeitsmappe " & wb.Name & _
" darf dieses Makro nicht ausgeführt werden!"
Exit Sub
End If
With wb.VBProject
For Each myVBComponents In .VBComponents
Select Case myVBComponents.Type
Case 1, 2, 3
With myVBComponents.CodeModule
.DeleteLines 1, .CountOfLines
End With
.VBComponents.Remove .VBComponents(myVBComponents.Name)
Case 100
With myVBComponents.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next
End With
wb.Save
wb.Close
Set wb = Nothing
' End If 'zur Sicherheitsabfrage
Fehler:
If Err.Number 0 Then
MsgBox "Fehler: " & Err.Number & vbLf & Err.Description & vbLf _
& "VBA-Code wurde ggf. wegen Sperrung des Zugriffs nicht gelöscht!"
If Not wb Is Nothing Then wb.Close savechanges:=False
End If
Application.ScreenUpdating = True
End Sub