AW: Noch nicht ganz......
12.01.2019 10:10:20
Sepp
Hallo Steve,
dann so:
Modul Modul1
Option Explicit
Sub speichern()
Dim strPath As String
Dim strFile As String
Dim strExt As String
Dim strNewFile As String
Dim varFile As Variant
strPath = ThisWorkbook.Path
varFile = Split(Split(ThisWorkbook.Name, ".")(0), "_")
strExt = Split(ThisWorkbook.Name, ".")(1)
If IsNumeric(varFile(Ubound(varFile))) Then Redim Preserve varFile(Ubound(varFile) - 1)
strFile = strFile & Join(varFile, "_") & "($)." & strExt
strNewFile = NextFileIndexName(strPath, strFile, "_0", 1)
If Len(strNewFile) Then
MsgBox "Die Datei '" & strNewFile & "' wird neu angelegt!"
ActiveWorkbook.SaveAs Filename:=strNewFile
Else
MsgBox "Fehler"
End If
End Sub
Private Function NextFileIndexName(ByVal FilePath As String, ByVal FileNamePattern As String, Optional ByVal IndexFormat As _
String = "-0", Optional ByVal StartIndex As Long = 0, Optional ByVal ShowNullIndex As Boolean = True) As String
'PARAMETERINFO:
'FilePath = Directory where the file is or should be located.
'FileNamePattern = Filename where '($)' marks the position of index-number!
'IndexFormat = The desired Format of the indexnumber.
'StartIndex = Lower bound of the indexnumber.
'ShowNullIndex = If true, the index '0' will be shown in the filename.
Dim varFile As Variant, strCheck As String, strIndex As String, strTemp As String, lngIndex As Long
Const PLACEHOLDER As String = "($)"
On Error GoTo ErrorHandler
If InStr(1, FileNamePattern, PLACEHOLDER) = 0 Then GoTo ErrorHandler
If Len(FileNamePattern) <> Len(Replace(FileNamePattern, PLACEHOLDER, "")) + Len(PLACEHOLDER) Then GoTo ErrorHandler
If Dir(FilePath, vbDirectory) = "" Then GoTo ErrorHandler
If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"
varFile = Split(FileNamePattern, PLACEHOLDER)
lngIndex = StartIndex
Do
If lngIndex = 0 And ShowNullIndex Then
strIndex = Format(lngIndex, IndexFormat)
ElseIf lngIndex > 0 Then
strIndex = Format(lngIndex, IndexFormat)
End If
lngIndex = lngIndex + 1
strTemp = FilePath & varFile(0) & strIndex & varFile(1)
strCheck = Dir(strTemp, vbNormal)
Loop Until strCheck = ""
NextFileIndexName = strTemp
Exit Function
ErrorHandler:
NextFileIndexName = ""
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0