Datei speichern Makro

22/04/2009 - 20:51 von Klaus Fierenz | Report spam
Hallo zusammen,

wer kann mir helfen?
Ich möchte das folgende Makro ausführen, wenn man den Speichern Button
drückt.
Der Speicherbutton soll also quasi deaktiviert werden und dann das Makro
ausgeführt werden.
Das Speichern funktioniert auch unter Excel 2003. Nur nach dem Speichern
schmiert Excel ab.
Die Datei soll immer mit dem Dateinamen + einer hochzàhlenden Zahl
gespeichert werden.

Wer kann mir helfen das Makro zum Laufen zu bringen.

Der Dateiname lautet z.B. 090421_Test_v0001.xls
Und die v0001 soll hochgezàhlt werden.



Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As
Boolean)

Dim BasisDateiname As String
Dim BasisDateiname_ohne_Version As String
Dim Lànge_BasisDateiname As Double
Dim Lànge_BasisDateiname_ohne_Version As Double

Dim Basisdateiname_ohne_xls As String
Dim BasisVersionsnummer As Double
Dim neue_Versionsnummer As String

Dim Versionsnummer_string As String
Dim finale_Versionsnummer As String
Dim Neuer_Dateiname As String
Dim Lànge_Versionsnummer As Double

' Basteln des Strings zum Basisnamen
BasisDateiname = Application.ActiveWorkbook.FullName

Lànge_BasisDateiname = Len(BasisDateiname)
Lànge_BasisDateiname_ohne_Version = Lànge_BasisDateiname - 8
BasisDateiname_ohne_Version = Left(BasisDateiname,
Lànge_BasisDateiname_ohne_Version)

' Basteln neue Versionsnummer
Basisdateiname_ohne_xls = Left(BasisDateiname, Lànge_BasisDateiname - 4)

BasisVersionsnummer = Right(Basisdateiname_ohne_xls, 4)

neue_Versionsnummer = BasisVersionsnummer + 1

Versionsnummer_string = CStr(neue_Versionsnummer)

Lànge_Versionsnummer = Len(Versionsnummer_string)

Select Case Lànge_Versionsnummer
Case 1
finale_Versionsnummer = "0" & "0" & "0" & Versionsnummer_string
Case 2
finale_Versionsnummer = "0" & "0" & Versionsnummer_string
Case 3
finale_Versionsnummer = "0" & Versionsnummer_string
Case Else
finale_Versionsnummer = Versionsnummer_string
End Select

Neuer_Dateiname = BasisDateiname_ohne_Version & finale_Versionsnummer

Application.EnableEvents = False
ThisWorkbook.SaveAs (Neuer_Dateiname)
Application.EnableEvents = True
End Sub

Danke im voraus.

Klaus
 

Lesen sie die antworten

#1 Andreas Killer
23/04/2009 - 09:38 | Warnen spam
On 22 Apr., 20:51, "Klaus Fierenz" wrote:

Das Speichern funktioniert auch unter Excel 2003. Nur nach dem Speichern
schmiert Excel ab.


Ich denke das liegt daran das Du vergessen hast den aktuellen
Sppeichervorgang abzubrechen, denn wenn das File schon einen anderen
Namen hat, dann ist "im Speicher für Excel" das alte File nicht mehr
vorhanden.

Die Datei soll immer mit dem Dateinamen + einer hochzàhlenden Zahl
gespeichert werden.


Okay, ich denke da kann man doch einiges ausbessern, daher schreib ich
das mal neu. Getestet unter XL2000.

Andreas.

Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, _
Cancel As Boolean)
Dim fs As Object
Dim FName As String, Version As String, I As Integer

'Wenn "Speichern unter" oder das erste Mal gespeichert wird:
If SaveAsUI Then
MsgBox "Bitte speichern Sie die korrekte Versionsnummer ab!"
Exit Sub
End If

'Dateiname ohne Extension extrahieren
Set fs = CreateObject("Scripting.FileSystemObject")
FName = fs.GetBaseName(ActiveWorkbook.Name)

'Version ermitteln
I = Len(FName)
'Version besteht aus Zahlen 0-9 und hat max. 4 Stellen
Do While Mid(FName, I, 1) Like "[0-9]" And Len(FName) - I <= 4
I = I - 1
Loop
Version = Mid(FName, I + 1)

'Version erhöhen
Version = Format(CLng(Version) + 1, "0000")

'Neuen Dateinamen zusammensetzen
FName = Mid(FName, 1, I) & Version

'Kompletten Pfad generieren
FName = fs.BuildPath(ActiveWorkbook.Path, FName) & "." & _
fs.GetExtensionName(ActiveWorkbook.Name)

Application.EnableEvents = False
'Datei speichern
ActiveWorkbook.SaveAs FName
'Aktuellen Speichervorgang abbrechen
Cancel = True
Application.EnableEvents = True
End Sub

Ähnliche fragen