Dateinamen automatisch um fortlaufende Nummer Lola(1), Lola(2) ergänzen

[Schwipp]

Liebe Leute,
aus einer Masterdatei erzeuge ich Dateien mit den Namen Malte, Lola usw.
Manchmal ist es aber so, dass ich einen Fehler gemacht habe, und dass ich
die bereits gespeicherte Datei nicht überschreiben möchte,  

sondern den Dateinamen VOR .xls um ein zusätzliches Zeichen verlängern möchte, also Lola.xls, Lola..xls, Lola...xls
.
Wie muss ich den folgenden Code, der nicht von mir stammt,  ändern,  
damit das klappt?
Sub Abspeichern_neuer_Name()
Dim dName$
Dim DatName As String
 
DatName = ActiveWorkbook.Worksheets(1).Range("F20") ' in F20 steht Malte oder Lola... oder...
dName = ThisWorkbook.Path & "\Versuche\" & Range("F20") & ".xls
 
ActiveSheet.Copy
ActiveWorkbook.SaveAs dName
ActiveWorkbook.Close Savechanges:=False 
 
ActiveWorkbook.Save                      
Application.Quit                                                                      ' schließt Datei komplett
End Sub

Vielen Dank für Hilfe!
Ciao Schwipp

Nachtrag:

[Kuwer]

Hallo,

Sub Abspeichern_neuer_Name()

  Dim strN As String

  Dim strP As String

  Dim strZ As String

  

  strN = ActiveWorkbook.Worksheets(1).Range("F20") ' in F20 steht Malte oder Lola... oder...

  strP = ThisWorkbook.Path & "\Versuche\" '& Range("F20") & ".xls"

  strZ = "."

  

  Do

    If Dir(strP & strN & strZ & "xls") = "" Then

      Exit Do

    Else

      strZ = strZ & strZ

    End If

  Loop

  

  ActiveSheet.Copy

  ActiveWorkbook.SaveAs strP & strN & strZ & "xls"

  ActiveWorkbook.Close Savechanges:=False

   

  ActiveWorkbook.Save

  Application.Quit                              ' schließt Datei komplett

End Sub

Gruß Uwe

[Schwipp]

Uwe, herzlichen Dank, ich will das gleich mal testen!

[Kuwer]

Hallo,

mein vorheriger Code war Mist. Hier jetzt richtig und eine weitere Variante entsprechend Deinem Betreff mit Zähler in Klammern:

Option Explicit



Sub Abspeichern_neuer_Name_Punkte()

 Dim strN As String

 Dim strP As String

 Dim strZ As String

 

 strN = ActiveWorkbook.Worksheets(1).Range("F20") ' in F20 steht Malte oder Lola... oder...

 strP = ThisWorkbook.Path & "\Versuche\"

 strZ = "."

 

 Do

   If Dir(strP & strN & strZ & "xls") = "" Then

     Exit Do

   Else

     strZ = String(Len(strZ) + 1, strZ)

   End If

 Loop

 

 ActiveSheet.Copy

 ActiveWorkbook.SaveAs strP & strN & strZ & "xls"

 ActiveWorkbook.Close Savechanges:=False

  

 ActiveWorkbook.Save

 Application.Quit                              ' schließt Datei komplett

End Sub



Sub Abspeichern_neuer_Name_Zaehler()

 Dim strN As String

 Dim strP As String

 Dim lngZ As Long

 

 strN = ActiveWorkbook.Worksheets(1).Range("F20") ' in F20 steht Malte oder Lola... oder...

 strP = ThisWorkbook.Path & "\Versuche\"

 lngZ = 1

 

 Do

   If Dir(strP & strN & "(" & lngZ & ").xls") = "" Then

     Exit Do

   Else

     lngZ = lngZ + 1

   End If

 Loop

 

 ActiveSheet.Copy

 ActiveWorkbook.SaveAs strP & strN & "(" & lngZ & ").xls"

 ActiveWorkbook.Close Savechanges:=False

  

 ActiveWorkbook.Save

 Application.Quit                              ' schließt Datei komplett

End Sub

Code eingefügt mit: Excel Code Jeanie

Gruß Uwe

[Schwipp]

Hallo Uwe,
Im Archiv bei "Herber" habe ich sowas ähnliches gefunden, die Kombination Deines Codes mit dem des Archivs war aber noch nicht erfolgreich...
Hinsichtlich der Abfragen und der Messagebox-Anzeigen funktioniert das dem Archiv ,
und lautet für mich angepasst:

Sub TestText()
Dim TB As Worksheet
Dim dName$
Set TB = ActiveWorkbook.Worksheets(5) ' was bedeutet die 5?
dName = "F:\Versuche\ " & Range("F20") & ".xls"
If Dir$(dName, vbNormal) <> "" Then
MsgBox "'Datei ist vorhanden; "
Else
MsgBox "'Datei ist nicht vorhanden"
End If
End Sub

Vielen herzlichen Dank für Deine Mühe,
ciao Schwipp


Also ich probier jetzt erstmal Deine elegante Variante mit Zähler in Klammern!!! (reimt sich ja sogar!)

[Schwipp]

Uwe, genial, Klammerversion klappt perfekt auf Anhieb, 1000 Dank !