Sub GetRenameFiles()
Dim oFD As FileDialog
Dim strFolder As String
Dim strFile As String
Dim oDoc As Document
Dim oRng As Range
Dim oFSO As Object
  Set oFSO = CreateObject("Scripting.FileSystemObject")
  
    Set oFD = Application.FileDialog(msoFileDialogFolderPicker)
    With oFD
        .Title = "Select the folder that contains the files."
        If .Show = -1 Then
            strFolder = .SelectedItems(1) & "\"
        Else
            MsgBox "You did not select a folder."
            Exit Sub
        End If
    End With
    strFile = Dir$(strFolder & "*.doc*")
    While strFile <> ""
        Set oDoc = Documents.Open(strFolder & strFile)
        Set oRng = oDoc.Range
        With oRng.Find
            .Text = "Title"
            If .Execute Then
                oRng.MoveEndUntil Chr(13)
                oRng.Start = oRng.Start + 7
            End If
        End With
        If Not oFSO.FileExists(oDoc.Path & "\" & oRng.Text & Right(oDoc.Name, Len(oDoc.Name) - InStr(oDoc.Name, ".") + 1)) Then
          oDoc.SaveAs2 oRng.Text
        Else
          oDoc.SaveAs2 oRng.Text & "-dup"
        End If
        
        oDoc.Close
        strFile = Dir$()
    Wend
End Sub