Combinación de correspondencia varios registros de un mismo socio por carta de excel a word varias tablas
Para Dante Amor
Necesitaría realizar una combinación de correspondencia utilizando macros. Necesito rellenar una plantilla word donde en texto inicial están los datos de la persona y seguidamente dos tablas con datos de la misma.
En una consulta de hace unos 3 años ya me mostró como realizar esto mismo pero en el documento word solo aparecía una tabla ahora son dos tablas distintas. Lo he intentado por mi cuenta pero creo que he empeorado la cosa.
1 respuesta
A qué te refieres con 2 tablas distintas. Podrías compartir tus archivos de word y de excel en la nube. Podría ser en dropbox o en google drive.
Si tienes datos confidenciales puedes reemplazarlos con datos genéricos.
Si puedes en un tercer archivo, en uno de word, me pones el resultado que necesitas.
Claro sin problema adjunto los 3 archivos. El word llamado documento original... es como debería de quedar. Si no aparecen dígame como debo subirlos aquí.
Envíame los archivos por correo a:
vale ¡Gracias! se los envío de nuevo
Prueba el siguiente código
Sub Llenar_Modelo()
'
' Por Dante Amor
' Fecha Creacíón: 14dic2017
' Fecha modificación: 09sep2020
'
'Declaración de variables
Dim h1 As Worksheet, h2 As Worksheet, h3 As Worksheet
Dim dic As Object, objWord As Object, ky As Variant
Dim i As Long, j As Long, u1 As Long, u3 As Long
Dim ruta As String, patharch As String, nombd As String
Dim textobuscar As String
'
Application.ScreenUpdating = False
Application.StatusBar = False
Application.DisplayAlerts = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("frm")
Set h3 = Sheets("tabla")
Set dic = CreateObject("Scripting.Dictionary")
'
'Valores únicos
If h1.AutoFilterMode Then h1.AutoFilterMode = False
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To u1
If Not dic.exists(h1.Range("C" & i).Value) Then dic(h1.Range("C" & i).Value) = i
Next
'
For Each ky In dic.keys
Application.StatusBar = "Procesando archivo : " & i & " de : " & dic.Count
'copia formato1
h3.Cells.Clear
h2.Range("A1:Q1").Copy
h3.Range("A1").PasteSpecial xlPasteAll
h3.Range("A1").PasteSpecial xlPasteColumnWidths
'
'filtra un nombre
h1.Range("A1:Q" & u1).AutoFilter Field:=3, Criteria1:=ky
h1.Range("G2:Q" & u1).Copy h3.Range("C2")
'copia formato2
u3 = h3.Range("C" & Rows.Count).End(xlUp).Row
h2.Range("A2:B2").Copy h3.Range("A2:A" & u3)
h3.Range("A1:Q" & u3).Borders.LineStyle = xlContinuous
'h3.Columns("A:Q").WrapText = False
h3.Columns("A:Q").EntireColumn.AutoFit
h3.Range("G2:I" & u1).Delete xlToLeft
'
'Llena plantilla de word
ruta = ThisWorkbook.Path & "\"
patharch = ruta & "plantilla39.dot"
'
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0
'
For j = 1 To Columns("N").Column
textobuscar = "[" & h1.Cells(1, j) & "]"
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
'
While objWord.Selection.Find.found = True
objWord.Selection.Text = h1.Cells(dic(ky), j) 'texto a reemplazar
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=textobuscar
Wend
Next
'
'Copia y Pega la tabla
h3.Range("A1:F" & u3).Copy
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:="[TABLA]"
objWord.Selection.PasteAndFormat 16 'Type:=wdListCombineWithExistingList
'https://msdn.microsoft.com/en-us/vba/word-vba/articles/wdrecoverytype-enumeration-word
'
'Copia y Pega la tabla2
H3.Range("E1:G" & u3). Copy
ObjWord. Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:="[TABLA2]"
ObjWord. Selection. PasteAndFormat 16
'
nombd = ruta & ky & ".docx"
'nombp = ruta & nombre & ".pdf"
objWord.ActiveDocument.SaveAs nombd
'pdf = objWord.ActiveDocument.ExportAsFixedFormat( _
nombp, 17, False, 0, 0, , , 0, False, True, 1)
objWord.Quit (False)
'
Next
'
If h1.AutoFilterMode Then h1.AutoFilterMode = False
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "Archivos generados", vbInformation, "PROCESO TERMINADO"
End Sub
