Macro en Excel para llenar plantilla de Word

Necesito de su apoyo, tengo una serie de datos en una hoja Excel y necesito llevarlos a una plantilla en word a través e una macro.
Me pasaron una macro pero hay que ir generando uno a uno cada registro ya que hay que ir seleccionar uno a uno y dar click al botón generar y lo que necesito es que de una sola vez al dar click al botón generar me genere todos los comprobantes, si es posible 3 comprobantes por pagina de Word para ahorrar papel.

Este es un ejemplo de la base de Excel la cual puede tener n cantidad de registros

Hoja Parámetros

Código de la macro

Sub Generar()
Dim objWord As Word.Application
Set a = Sheets("Parametros")
'Ubicacion y nombre de plantilla
wArch = a.Range("D3").Text & a.Range("D2").Text & ".docx"
Set objWord = CreateObject("Word.Application")

objWord.Visible = True
objWord.Documents.Add template:=wArch, NewTemplate:=False, DocumentType:=0

For i = 1 To a.Range("D1").Value 'Celda donde esta el total de variables

datos = a.Range("B" & i) 'Donde estan los datos
reemp = a.Range("A" & i) 'Donde estan las etiquetas

'Utilizamos buscar y reemplazar en Word
With objWord.Selection.Find
.Text = datos 'Busca el texto de datos
.Replacement.Text = reemp 'Reemplaza por el texto
.Execute Replace:=2 ' La variable en 2 es para reemplazar todos los valores
End With
Next i

objWord.Activate
End Sub

Esta es la plantilla del comprobante

1 respuesta

Respuesta
2

Desconozco cómo se haría para realizar todos los recibos en un solo documento de word.

Revisa si lo siguiente te ayuda.

Se va a generar un archivo por cada Nota de Abono.

El archivo se guardará con el nombre del beneficiario.

Los archivos se guardarán en la misma carpeta donde tienes la plantilla word.

Sub GenerarArchivos()
'Act Por Dante Amor
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim objWord As Word.Application
  Dim i As Long, j As Long
  Dim wArch As String, ruta As String, nombre As String
  Dim datos As Variant, reemp As Variant
  '
  Application.ScreenUpdating = False
  '
  Set sh1 = Sheets("Datos")       'Nombre de la hoja con los datos
  Set sh2 = Sheets("Parametros")
  'Ubicacion y nombre de plantilla
  wArch = sh2.Range("D3").Text & sh2.Range("D2").Text & ".docx"
  ruta = sh2.Range("D3").Text     'Carpeta donde se guardan los archivos
  '
  'Para cada registro de la hoja con datos
  For j = 2 To sh1.Range("B" & Rows.Count).End(3).Row
    Set objWord = CreateObject("Word.Application")
    'objWord.Visible = True
    objWord.Documents.Add template:=wArch, NewTemplate:=False, DocumentType:=0
    '
    nombre = sh1.Range("B" & j).Value     'nombre del archivo
    sh2.Range("A1").Value = sh1.Range("B" & j).Value
    sh2.Range("A2").Value = sh1.Range("C" & j).Value
    sh2.Range("A3").Value = sh1.Range("D" & j).Value
    sh2.Range("A4").Value = sh1.Range("F" & j).Value
    sh2.Range("A5").Value = sh1.Range("G" & j).Value
    sh2.Range("A6").Value = sh1.Range("A" & j).Value
    sh2.Range("A7").Value = sh1.Range("E" & j).Value
    '
    For i = 1 To sh2.Range("D1").Value 'Celda donde esta el total de variables
      datos = sh2.Range("B" & i).Value 'Donde estan los datos
      reemp = sh2.Range("A" & i).Value 'Donde estan las etiquetas
      '
      'Utilizamos buscar y reemplazar en Word
      With objWord.Selection.Find
        .Text = datos 'Busca el texto de datos
        .Replacement.Text = reemp 'Reemplaza por el texto
        .Execute Replace:=2 ' La variable en 2 es para reemplazar todos los valores
      End With
    Next i
    '
    'objWord.Activate
    ObjWord. ActiveDocument.SaveAs ruta & nombre
    objWord. ActiveDocument. Close
 objWord. Quit
  Next
  '
  Application.ScreenUpdating = True
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas