Datei Versionenweise in bestimmte Ordner speichern
03.01.2017 15:25:01
Nermin
ich möchte eine Datei immer Versionsweise abspeichern bsp.: bla_ver1.xl bla_ver2.xl usw und dann aber in einen bestimmten ordner der erstellt wird wenn nicht vorhanden. Soweit so gut:
Sub Schaltfläche48_Klicken()
Dim Cancel As Boolean
Dim vTemp
Dim Folder
Dim myDialog As Variant
Dim strShortName As String
Dim intVersion As Integer
Dim strExtension As String
Dim strNewName As String
Dim arrOrdner As Variant
Dim iOrdner As Integer
Dim sDrive As String, sOrdner As String, sTmp As String
sOrdner = InputBox("Zu erstellendes Verzeichnis:", , "S:\ETEYR\09_Komponenten_Baugruppen\Rohrleitungen\11_Rohrleitungskalkulation\Kalkulationen\Projekte\" & Worksheets("Cockpit").Cells(2, "O").Value)
On Error Resume Next
If sOrdner = "" Then Exit Sub
' If Right(sOrdner, 1) = "\" Then
sOrdner = Left(sOrdner, Len(sOrdner) - 1)
End If
arrOrdner = fncFolders(sOrdner)
For iOrdner = UBound(arrOrdner) To 1 Step -1
If fncIfFolderExists(CStr(arrOrdner(iOrdner))) Then
Else
MkDir arrOrdner(iOrdner)
End If
Next iOrdner
vTemp = Split(ThisWorkbook.Name, ".")
strShortName = vTemp(0)
intVersion = Val(vTemp(1)) + 1
strExtension = vTemp(UBound(vTemp))
On Error GoTo 0
strNewName = strShortName & "." & intVersion & "." & strExtension
If ThisWorkbook.Saved = True And _
ThisWorkbook.Name = strNewName Then
MsgBox "Die Datei " & ThisWorkbook.Name & _
" wurde nicht verändert.", vbInformation
Else
myDialog = MsgBox("Änderungen als " & vbCrLf & _
strNewName & vbCrLf & _
"speichern?", vbYesNoCancel + vbQuestion)
Application.EnableEvents = False
Select Case myDialog
Case vbYes
' Folder = Worksheets("Cockpit").Cells(2, "O").Value
' ThisWorkbook.SaveAs Filename:= _
' "S:\ETEYR\09_Komponenten_Baugruppen\Rohrleitungen\11_Rohrleitungskalkulation\Kalkulationen\Projekte\ & Folder" & strNewName
Case Is = vbNo
MsgBox "Es wurde 'NEIN' gewählt. NICHT gesichert!"
Application.EnableEvents = True
ThisWorkbook.Close SaveChanges:=False
Case vbCancel
MsgBox "Es wurde ABBRECHEN gewählt. WIEDERHOLEN!"
Cancel = True
End Select
Application.EnableEvents = True
End If
End Sub
Private Function fncFolders(sFolder As String) As Variant
Dim arr() As String
Dim iCounter As Integer, iFolder As Integer
ReDim arr(1 To 1)
arr(1) = sFolder
iFolder = 1
For iCounter = Len(sFolder) To 4 Step -1
If Mid(sFolder, iCounter, 1) = "\" Or iCounter = 1 Then
iFolder = iFolder + 1
ReDim Preserve arr(1 To iFolder)
arr(iFolder) = Left(sFolder, iCounter - 1)
End If
Next iCounter
fncFolders = arr
End Function
Private Function fncIfFolderExists(sFolder As String) As Boolean
Dim sOld As String
sOld = CurDir
On Error Resume Next
ChDrive Left(sFolder, 1)
ChDir sFolder
If Err = 0 Then fncIfFolderExists = True
On Error GoTo 0
ChDrive Left(sOld, 1)
ChDir sOld
End Function
Liebe Grüße,
Nermin