Preenchimento automatico no word através de um banco de dados no excel.
Enviado: Ter Ago 20, 2019 10:08 am
Bom dia, tenho esse código abaixo e queria pegar o valor da célula e colocar em um local especifico no Word mas não estou conseguindo. Alguém por gentileza poderia me ajudar por favor? Desde já agradeço.
Ex: Nome = Jonas
CPF = 1234567-10
Ex: Nome = Jonas
CPF = 1234567-10
Código: Selecionar todos
Sub Criar_Doc()
Dim objWord As Object
Dim objDoc As Object
Dim i As Integer
Dim strValueA As String, strValueB As String, strValueC As String, strValueD As String
On Error GoTo erro
Set objWord = CreateObject("Word.Application") ' define o objeto
objWord.Visible = True
Set objDoc = objWord.Documents.Add ' cria um novo doc
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
With Sheets("Plan1")
objDoc.Activate
strValueA = .Cells(i, 1): strValueB = .Cells(i, 2): strValueC = .Cells(i, 3): strValueD = .Cells(i, 4) ' define os valores a string
objWord.Selection.TypeText Text:=strValueA & " " & strValueB & " " & strValueC & " " & strValueD & ""
objWord.Selection.TypeParagraph ' move p/ prox linha
End With
Next i[/highlight][/highlight][/highlight]
If Dir(Environ("USERPROFILE") & "\Desktop\MeuNovoDoc.doc") <> "" Then ' verif se ja existe o doc c/ o mesmo nome..
Kill Environ("USERPROFILE") & "\Desktop\MeuNovoDoc.doc" ' ...se existir exclui
End If
objDoc.SaveAs (Environ("USERPROFILE") & "\Desktop\MeuNovoDoc.doc") ' * Salva o documento na pasta "Desktop"
MsgBox "O novo domumento foi salvo em: " & Environ("USERPROFILE") & "\Desktop\MeuNovoDoc.doc", 0, "Sucesso" ' msg
objWord.Quit ' fecha o doc
Set objWord = Nothing
Exit Sub
erro: MsgBox Err.Description, vbCritical, "Atenção!!!"
End