Try:
Code:
Sub ReSave()
Dim StrName As String, StrExt As String, StrNum As String, Rslt
With ActiveDocument
StrName = .Name
StrExt = Right(StrName, Len(StrName) - InStrRev(StrName, ".") + 1)
StrName = Left(StrName, InStrRev(StrName, ".") - 1)
StrNum = Format(Split(StrName, " ")(UBound(Split(StrName, " "))) + 1, "00")
StrName = Left(StrName, InStrRev(StrName, " "))
StrName = .Path & "\" & StrName & StrNum & StrExt
If Dir(StrName) <> "" Then
Beep
Rslt = MsgBox("The new filename:" & vbCr & StrName & vbCr & "already exists." & _
vbCr & "Continue saving (overwrite existing file)?", vbOKCancel)
If Rslt = vbCancel Then Exit Sub
End If
.SaveAs2 FileName:=StrName, FileFormat:=.SaveFormat
End With
End Sub