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