Recurring errors generating a word file from fields in an excel spreadsheet (VBA)

Good afternoon, I have never programmed in VBA but I found myself in a need where I am needing to generate a word document from some cells of a spreadsheet in excel, after searching several sites on the internet I managed to make a script that works, the problem is that randomly it is giving the error below, I know that the script is probably not good but it is functional, the problem really is only this error that happens time or another, when the same occurs and I copy the cell again and send continue it follows normally, in the case of print below he had already generated 22 files and in the 23rd he presented this error.

Dim path_src As String
Dim path_dest As String
Dim nome_dest As String
' Define word object
Dim WA As Object
Dim cs As Worksheet
Dim linha As Integer
Dim xRg As Range
Dim I As Variant
Dim proj As String
Dim cen As String
Dim amb As String




Function copiar(cel1 As String)
    cs.Range(cel1).Copy
End Function


Sub criarEv()



    'Planilha

    Set cs = ActiveWorkbook.Worksheets("Plan1")
    'seleção de casos de teste
    Set xRg = Application.InputBox("Selecione os casos de testes", "Teste", ActiveWindow.RangeSelection.Address, , , , , 8)
    proj = InputBox("Informe o nome do projeto")
    nome_dest = InputBox("Informe o caminho para salvar as evidencias")

    path_src = "R:\MelhoriasQA\templates\template caso de teste.doc"
    amb = InputBox("Informe o ambiente em que os testes serão executados:")

    ' Data worksheet "Data" col A find text, Col B replace text
    Set cs = ActiveWorkbook.Worksheets("Plan1")

    Set WA = CreateObject("Word.Application")

    WA.Visible = True

    ' Verificar possibilidade de passar este carra como parametro
    linha = 6

    ' Este TB


    I = 1

    For Each I In xRg


        ' Abertura da planilha
        WA.Documents.Open (path_src)

        ' Set word object active
        WA.Activate
        WA.Selection.MoveRight Unit:=wdCell
        WA.Selection.MoveRight Unit:=wdCell
        WA.Selection.MoveRight Unit:=wdCell
        WA.Selection.MoveRight Unit:=wdCell
        'Projeto:
        WA.Selection.TypeText Text:=proj
        WA.Selection.MoveRight Unit:=wdCell
        WA.Selection.MoveRight Unit:=wdCell
        'Cenário:
        copiar "b" & linha
        WA.Selection.PasteAndFormat (wdFormatPlainText)
        WA.Selection.MoveRight Unit:=wdCell
        WA.Selection.MoveRight Unit:=wdCell
        'Pré-requisito para teste:
        copiar "g" & linha
        WA.Selection.PasteAndFormat (wdFormatPlainText)
        WA.Selection.MoveRight Unit:=wdCell
        WA.Selection.MoveRight Unit:=wdCell
        'Caso de Teste:
        copiar "c" & linha
        WA.Selection.PasteAndFormat (wdFormatPlainText)
        WA.Selection.TypeText Text:=" - "
        copiar "d" & linha
        WA.Selection.PasteAndFormat (wdFormatPlainText)
        WA.Selection.MoveRight Unit:=wdCell
        WA.Selection.MoveRight Unit:=wdCell
        'Resultado Esperado:
        copiar "i" & linha
        WA.Selection.PasteAndFormat (wdFormatPlainText)
        'Ambiente
        WA.Selection.MoveRight Unit:=wdCell
        WA.Selection.MoveRight Unit:=wdCell
        WA.Selection.TypeText Text:=amb
        WA.Selection.MoveDown Unit:=wdLine, Count:=3
        'Passos
        copiar "h" & linha
        WA.Selection.PasteAndFormat (wdFormatPlainText)
        WA.Selection.TypeParagraph
        cen = "c" & linha


        path_dest = nome_dest & "\" & proj & "_RTXXX_" & "CT" & cs.Range(cen).Value & ".doc"


        WA.Application.ActiveDocument.SaveAs path_dest
        WA.Documents.Close

        linha = linha + 1
    Next
    MsgBox ("Feito!!!")
    Set WA = Nothing
End Sub