Vba Excel导出到表格，最后一步会卡死，报自动化错误请各位师傅看看

麻烦帮我看看最后面为什么会循环报错

Private Sub CommandButton1_Click()
On Error GoTo Err_cmdExportToWord_Click
Dim objApp As Object 'Word.Application
Dim objDoc As Object 'Word.Document
Dim strTemplates As String '模板文件路径名
Dim strFileName As String '将数据导出到此文件
Dim i As Integer
Dim contact_NO As String
Dim side_A As String
Dim side_B As String

i = ActiveCell.Row
contact_NO = Cells(i, 3)
side_A = Cells(i, 4)
side_B = Cells(i, 5)
Dim sPathOld As String '源文件
Dim sPathNew As String
Dim sFileName As String
'获取源文件平路径
sPathOld = "E:\Desktop\模板1\1"
sPathNew = "E:\Desktop" & side_B
strTemplates = "E:\Desktop" & side_B & "\公文处理签222" & ".doc"
sFileName = "公文处理签222" & ".doc"
Set fs = CreateObject("Scripting.FileSystemObject")
'提取文件名
Spath = Dir(sPathOld, vbDirectory)
'判断文件
Do While Len(Spath)
If Spath <> "." And Spath <> "." Then
fs.CopyFolder sPathOld, sPathNew
End If
Spath = Dir()
Loop

'打开模板文件
Set objApp = CreateObject("Word.Application")
objApp.Visible = True
Set objDoc = objApp.Documents.Open(strTemplates, , False)
'开始替换模板预置变量文本
With objApp.Application.Selection
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
With .Find
.Text = "{$编号}"
.Replacement.Text = contact_NO
End With
.Find.Execute Replace:=wdReplaceAll

With .Find
.Text = "{$来文单位}"
.Replacement.Text = side_A
End With
.Find.Execute Replace:=wdReplaceAll

With .Find
.Text = "{$收件时间}"
.Replacement.Text = side_B
End With
.Find.Execute Replace:=wdReplaceAll
End With

'将写入数据的模板另存为文档文件
objDoc.SaveAs sFileName ( '这里不懂填什么，还是填strTemplates)
objDoc.Saved = True
MsgBox "合同文本生成完毕！", vbYes + vbExclamation
Exit_cmdExportToWord_Click: ( '在这部分会最后合同文本生成完毕后报错进入循环，表格卡死)
If Not objDoc Is Nothing Then objApp.Visible = True
Set objApp = Nothing
Set objDoc = Nothing
Set objTable = Nothing
Exit Sub
Err_cmdExportToWord_Click:
MsgBox Err.Description, vbCritical, "出错"
End Sub