Excel automation fails second time code runs

[Mr Sin]

After running the code, its shows "the remote server machine does not exist or is not available".
Could anyone offer help on reviewing my code. Many thanks.

Sub CopyFilterResult()
' This loop repeats for generate multiple word document by ID
' in the range
Dim objWordApp As Word.Application
Dim objWord As Word.Document
Dim i As Long
Dim lastcell As Long
On Error GoTo errHandle

'--criteria
With Worksheets("id")
lastcell = Sheets("id").Range("A" & Rows.Count).End(xlDown).Row
For i = 2 To lastcell
Worksheets("Sheet4").Cells.Clear
Worksheets("Target").Range("A2").Clear
Sheets("Target").Cells(2, 1).Value = Sheets("id").Cells(i, 1).Value

'--select target content to Sheet 4
With Worksheets("Sheet1")
.Range("A1").CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, CriteriaRange:=Worksheets("Target").Range("A1:A2").SpecialCells(xlCellTypeVisible), _
CopyToRange:=Worksheets("Sheet4").Range("A1"), Unique:=True
End With

'--copy excel content to word
With Worksheets("Sheet4")
Set rngCopy = Worksheets("Sheet4").Range("A1:D" & .Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
End With

Set objWordApp = New Word.Application
Set objWord = objWordApp.Documents.Add
objWord.Application.Visible = True

'--paste content
With objWord.Application
.Selection.Style = .ActiveDocument.Styles("Normal")
.Selection.TypeParagraph
rngCopy.Copy
.Selection.PasteExcelTable False, False, False
End With

objWord.SaveAs
FPath = "XXXXXXXXXX"
FName = Worksheets("Sheet4").Range("A2").Value
ActiveDocument.SaveAs Filename:=FPath & "\" & FName & ".doc", _
FileFormat:=wdFormatDocument
objWord.Close Savechanges:=True
objWordApp.Quit
Next i
End With
errExit:
Set objSel = Nothing
Set objWord = Nothing
Set objWordApp = Nothing
Exit Sub
errHandle:
MsgBox Err.Description
Resume errExit
End Sub