Boa tarde, nunca programei em VBA mas me encontrei em uma necessidade onde estou precisando de gerar uma documento word a partir de algumas células de uma planilha no excel, depois de procurar vários sites na internet consegui fazer um script que funciona, o problema é que aleatoriamente está dando o erro abaixo, sei que o script provavelmente não está bom mas ele está funcional, o problema realmente é somente esse erro que acontece vez ou outra, quando o mesmo ocorre e eu copio a célula novamente e mando continuar ele segue normalmente, no caso do print abaixo ele já tinha gerado 22 arquivos e no 23º ele apresentou esse erro.
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
Set cs = ActiveWorkbook.Worksheets("Plan1")
paraSet cs = ThisWorkbook.Worksheets("Plan1")
. E a função copiar para inserir um worksheet:Function copiar(cel1 As String, cs as Worksheet)