Recursive errors generating a word file from the fields of an Excel worksheet (VBA)

Good afternoon, I never programmed in VBA but I found myself in a need where I need to generate a word document from some cells of a worksheet in excel, after searching several websites on the internet I was able to make a script that works, the Problem is that it is randomly 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 occasionally, when the same occurs and I copy the cell again and have it continue it usually follows, in the case of the print below it had already generated 22 files and in the 23rd it presented this error.

Dimpath_srcAsStringDimpath_destAsStringDimnome_destAsString'DefinewordobjectDimWAAsObjectDimcsAsWorksheetDimlinhaAsIntegerDimxRgAsRangeDimIAsVariantDimprojAsStringDimcenAsStringDimambAsStringFunctioncopiar(cel1AsString)cs.Range(cel1).CopyEndFunctionSubcriarEv()'PlanilhaSetcs=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