Guardar copia de libro autonumerada

No se me había ocurrido hacer algo así, pero ahí va.
Este código tienes que ponerlo en el código VB del workbook:
Option Explicit
Dim snCambiandoNombre As Boolean
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim nomFich As String
    Dim miNombre As String
    Dim n As Integer
    If snCambiandoNombre Then Exit Sub
    miNombre = ThisWorkbook.Path & "\" & ThisWorkbook.Name
    ' Si no existe el fichero dejamos que siga el proceso sin hacer nada
    If Not existeFichero(ThisWorkbook.Path & "\" & ThisWorkbook.Name) Then Exit Sub
    ' Si pasa por aquí es que ya existe. Primero quitamos la extensión XLS
    If UCase$(Right$(miNombre, 4)) = ".XLS" Then miNombre = Left$(miNombre, Len(miNombre) - 4) ' Quitamos el XLS
    ' Ahora miramos si ya es una versión (un número entre paréntesis), en ese caso lo quitamos
    ' Primero comprobamos si es una versión con un sólo dígito estilo (2)
    If Len(miNombre) > 3 Then
        If Mid$(miNombre, Len(miNombre) - 2, 1) = "(" And Mid$(miNombre, Len(miNombre), 1) = ")" And IsNumeric(Mid$(miNombre, Len(miNombre) - 1, 1)) Then
            ' Quitamos el número de versión del nombre
            miNombre = Left$(miNombre, Len(miNombre) - 3)
        End If
    End If
    ' Después comprobamos si es una versión con dos dígitos estilo (14)
    If Len(miNombre) > 4 Then
        If Mid$(miNombre, Len(miNombre) - 3, 1) = "(" And Mid$(miNombre, Len(miNombre), 1) = ")" And IsNumeric(Mid$(miNombre, Len(miNombre) - 1, 2)) Then
            ' Quitamos el número de versión del nombre
            miNombre = Left$(miNombre, Len(miNombre) - 4)
        End If
    End If
    ' Ya tenemos el nombre de este fichero sin extensión ni posible número de versión
    ' Ahora buscamos el número de versión nuevo (uno que no exista)
    n = 2
    Do
        nomFich = miNombre & "(" & Format$(n) & ").xls"
        If Not existeFichero(nomFich) Then Exit Do ' Este nos vale
        n = n + 1
    Loop
    ' Guardaremos el libro con el otro nombre y cancelaremos el proceso de guardado actual
snCambiandoNombre = True
    ThisWorkbook.SaveAs nomFich
    snCambiandoNombre = False
    ' Cancelamos el guardado del fichero actual
    Cancel = True
End Sub
Function existeFichero(ByVal nomFich As String) As Boolean
    Dim d As String
    On Error Resume Next
    d = Dir$(nomFich)
    If Err <> 0 Then d = nomFich
    On Error GoTo 0
    existeFichero = (d <> "")
End Function