Correspondencia a Word de una Base de Datos de Excel para Crear Documentos Seleccionando la Fila y Escogiendo la Ubicación
He visto que sueles responder preguntas acerca de VBA y macros, entonces agradecería mucho si me podrías echar una mano con este proyecto que tengo.
Te cuento tengo una base de datos, ejemplo.
Lo que quiero es que se pueda escoger que fila quieres para llenar una plantilla.
Y que al final se guarde de forma automática en un lugar seleccionado que en este caso sería el folder.
C:\Users\galoj\Downloads\Prueba Local\Prueba Local
Ya tengo un código, pero tienen varios problemas. Si jala y si llena la correspondencia que escojo. Pero por alguna razón lo hace 33 veces y guarda 33 archivos que son el número de filas que tengo. También lo quiero guardar como pdf pero no me deja. Lo principal que quiero arreglar justo es que nada más cree un archivo que sea el que escoja. Te pongo mi código. De antemano muchas gracias.
Sub PruebaLocal()
' Declaracion de Variables
Dim carpeta As String
Dim renglon As Integer
' Asignacion de valores a variables
carpeta = InputBox("Copie aquí la dirección de la carpeta destino. Por ejemplo: ", "Carpeta destino", "N:\temp\")
renglon = InputBox("Escriba la fila/renglón que desee usar para generar contratos")
'
patharch = ThisWorkbook.Path & "\Prueba Local Plantilla.dotx"
'
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0
'
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
textobuscar = Cells(1, j)
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
'
While objWord.Selection.Find.found = True
objWord.Selection.Text = Cells(renglon, j) 'texto a reemplazar
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
Wend
'
Next
ruta = carpeta & "\"
nombd = "Prueba Local Word " & i & ".docx"
nombp = "Prueba Local PDF " & i & ".pdf"
objWord.ActiveDocument.SaveAs ruta & nombd
pdf = objWord.ActiveDocument.ExportAsFixedFormat(nombp, _
17, False, 0, 0, , , 0, False, True, 1)
objWord.Quit (True)
Next
End Sub
1 Respuesta
[Hola y bienvenido a todoexpertos!
Prueba con lo siguiente:
Sub PruebaLocal()
'Por Dante Amor
'
' Declaración de Variables
Dim carpeta As String, patharch As String, ruta As String
Dim textobuscar As String, nombd As String, nombp As String, pdf As String
Dim i As Long, j As Long
Dim objWord As Object
' Asignacion de valores a variables
carpeta = InputBox("Copie aquí la dirección de la carpeta destino. Por ejemplo: ", "Carpeta destino", "N:\temp\")
i = InputBox("Escriba la fila/renglón que desee usar para generar contratos")
'
patharch = ThisWorkbook.Path & "\Prueba Local Plantilla.dotx"
'
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0
'
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
textobuscar = Cells(1, j)
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
'
While objWord.Selection.Find.found = True
objWord.Selection.Text = Cells(i, j) 'texto a reemplazar
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
Wend
'
Next
If Right(carpeta, 1) <> "\" Then ruta = carpeta & "\" Else ruta = carpeta
nombd = "Prueba Local Word " & i & ".docx"
nombp = "Prueba Local PDF " & i & ".pdf"
ObjWord. ActiveDocument.SaveAs ruta & nombd
objWord. ActiveDocument. ExportAsFixedFormat ruta & nombp, 17, False, 0, 0,,, 0, False, True, 1
objWord. Quit (True)
End Sub
