It seems OK and works here, but there is no need to close the document and re-open the original, just save it again with the original name, and you can define the actual folder for the user and ensure that it is present e.g.
Option Explicit
Sub SaveBackUpCopy()
Dim strPath As String
Dim lFmt As Long
Dim strOriginal As String
strPath = Environ("USERPROFILE") & "\Desktop\in process documents\misc\backups\"
CreateFolders strPath
Application.ScreenUpdating = False
With ActiveDocument
.Save
If .path = "" Then
MsgBox "The document must be saved first!"
Exit Sub
End If
lFmt = .SaveFormat
strOriginal = .FullName
'.AcceptAllRevisions
.TrackRevisions = False
With ActiveWindow.View.RevisionsFilter
.Markup = wdRevisionsMarkupNone
.View = wdRevisionsViewFinal
With ActiveDocument
.Save
End With
End With
.SaveAs2 FileName:=strPath & .Name, _
fileFormat:=lFmt, _
AddToRecentFiles:=False
.SaveAs2 FileName:=strOriginal, _
fileFormat:=lFmt, _
AddToRecentFiles:=False
End With
Application.ScreenUpdating = True
End Sub
Private Function CreateFolders(strPath As String)
'Graham Mayor - http://www.gmayor.com - Last updated - 31 May 2017
'Creates the full path 'strPath' if missing or incomplete
Dim strTempPath As String
Dim lng_Path As Long
Dim VPath As Variant
Dim oFSO As Object
Dim i As Integer
Set oFSO = CreateObject("Scripting.FileSystemObject")
VPath = Split(strPath, "\")
If Left(strPath, 2) = "\\" Then
strPath = "\\" & VPath(2) & "\"
For lng_Path = 3 To UBound(VPath)
strPath = strPath & VPath(lng_Path) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lng_Path
Else
strPath = VPath(0) & "\"
For lng_Path = 1 To UBound(VPath)
strPath = strPath & VPath(lng_Path) & "\"
If Not oFSO.FolderExists(strPath) Then MkDir strPath
Next lng_Path
End If
lbl_Exit:
Set oFSO = Nothing
Exit Function
End Function