Sub aa()
Dim A$
Dim Suffixe$
Dim Prefixe$
Dim Increment&
'--- Suffixe et prefixe du nom du classeur ---
A$ = ThisWorkbook.Name
Suffixe$ = Mid(A$, InStrRev(A$, "."))
Prefixe$ = Mid(A$, 1, Len(A$) - Len(Suffixe$) - 3)
'--- Fait une copie du classeur en incrémentant sa numérotation ---
'--- (n'écrase pas les classeurs déjà existants) ---
Do
If Dir(ThisWorkbook.Path & "\" & Prefixe$ & Format(Increment&, "000") & Suffixe$) = "" Then
ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & Prefixe$ & Format(Increment&, "000") & Suffixe$
Exit Do
Else
Increment& = Increment& + 1
End If
Loop
End Sub