Con una macro ejecutar varias plantillas en word

H o l a:

Te anexo la macro actualizada

Sub exportaraword2()
    'Codigo escrito por Manuel Vizcarra - wwww.combito.com
    Dim datos(0 To 1, 0 To 2) As String '(columna,fila)
    'Act.Por.Dante Amor
    plas = Array("Proc Cont. IE El Diamante ENSAYO.dotx", _
                 "plantilla2.dotx", _
                 "plantilla3.dotx", _
                 "plantilla4.dotx")
    For pl = LBound(plas) To UBound(plas)
        patharch = ThisWorkbook.Path & "\" & plas(pl)
        Set ObjWord = CreateObject("Word.Application")
        ObjWord.Visible = True
        ObjWord.Documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0
        datos(0, 0) = "COPIA_OBJETO"
        datos(1, 0) = Hoja1.Cells(4, 1) '(fila,columna)
        datos(0, 1) = "COPIAR_FECHA"
        datos(1, 1) = Hoja1.Cells(5, 1)
        datos(0, 2) = "FECHA_INV"
        datos(1, 2) = Hoja1.Cells(6, 1)
        For i = 0 To UBound(datos, 2)
            textobuscar = datos(0, i)
            ObjWord.Selection.Move 6, -1
            ObjWord.Selection.Find.Execute FindText:=textobuscar
            While ObjWord.Selection.Find.found = True
                ObjWord.Selection.Text = datos(1, i) 'texto a reemplazar
                ObjWord.Selection.Move 6, -1
                ObjWord.Selection.Find.Execute FindText:=textobuscar
            Wend
        Next i
        'para crear las tablas
        Hoja1.Range("C37:G60").Select
        Selection.Copy
        textobuscar = "Copia_Cotizacion"
        ObjWord.Selection.Move 6, -1 'moverse al principio del documento
        ObjWord.Selection.Find.Execute FindText:=textobuscar
        While ObjWord.Selection.Find.found = True 'reemplaza el texto, y busca si hay otro para reemplazarlo
            ObjWord.Selection.PasteExcelTable False, True, False
            ObjWord.Selection.Move 6, -1
            ObjWord.Selection.Find.Execute FindText:=textobuscar
        Wend
        'tabla 2
        Hoja1.Range("C5:F14").Select
        Selection.Copy
        textobuscar = "COPIA_CRONOGRAMA"
        ObjWord.Selection.Move 6, -1 'moverse al principio del documento
        ObjWord.Selection.Find.Execute FindText:=textobuscar
        While ObjWord.Selection.Find.found = True 'reemplaza el texto, y busca si hay otro para reemplazarlo
            ObjWord.Selection.PasteExcelTable False, True, False
            ObjWord.Selection.Move 6, -1
            ObjWord.Selection.Find.Execute FindText:=textobuscar
        Wend
    Next pl
    ObjWord.Activate
End Sub

cambia en esta parte por los nombres de las plantillas 2, 3 y 4.

plas = Array("Proc Cont. IE El Diamante ENSAYO.dotx", _
"plantilla2.dotx", _
"plantilla3.dotx", _
"plantilla4.dotx")

' : )
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
' : )

¡Gracias! Dante amor

deseo que las macros se ejecutaran mediante un botón en la primera hoja, cuando esta en la hoja de los datos el botón se ejecuta normal, pero cuando lo copio en otra hoja el botón no ejecuta, sale un error 1004 y es por el rango de las tablas, sabrías indicarme que hacer por favor...un abrazo

Cambia en la macro en todas las líneas donde veas esto:

Hoja1

Y pon esto:

Activesheet

Al final de mi respuesta aparecen 2 opciones para valorar la respuesta:

"Votar" y "Excelente"

Si tu respuesta fue respondida, al final te aparece un botón que dice "Votada", selecciona ese botón y te aparece el botón "Cambiar VOTACIÓN"

Espero que puedas cambiar la valoración. Sal u dos

hola de nuevo Dante, antes de continuar darte mis mas sinceros agradecimientos y aclarar la duda, puesto que he hecho lo que me has indicado pero me copia las celdas de la hoja 1, y resulta que en la hoja 2 el botón funciona perfectamente, pero yo quiero que la macro se ejecute desde la hoja 1 mediante ese botón, y cuando lo copio y lo pego me pone problema en los rangos de las tablas que deben ejecutarse en las plantillas dot.

te anexo una imagen para explicarme un poco mejor

gracias de nuevo

Así quedaría la macro.

En esta línea de la macro:

Set h1 = Sheets("Hoja2")

Cambia "Hoja2" por el nombre de la hoja que tiene los datos.

Sub exportaraword2()
    'Codigo escrito por Manuel Vizcarra - wwww.combito.com
    Dim datos(0 To 1, 0 To 2) As String '(columna,fila)
    'Act.Por.Dante Amor
    Set h1 = Sheets("Hoja2")
    plas = Array("Proc Cont. IE El Diamante ENSAYO.dotx", _
                 "plantilla2.dotx", _
                 "plantilla3.dotx", _
                 "plantilla4.dotx")
    For pl = LBound(plas) To UBound(plas)
        patharch = ThisWorkbook.Path & "\" & plas(pl)
        Set ObjWord = CreateObject("Word.Application")
        ObjWord.Visible = True
        ObjWord.Documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0
        datos(0, 0) = "COPIA_OBJETO"
        datos(1, 0) = h1.Cells(4, 1) '(fila,columna)
        datos(0, 1) = "COPIAR_FECHA"
        datos(1, 1) = h1.Cells(5, 1)
        datos(0, 2) = "FECHA_INV"
        datos(1, 2) = h1.Cells(6, 1)
        For i = 0 To UBound(datos, 2)
            textobuscar = datos(0, i)
            ObjWord.Selection.Move 6, -1
            ObjWord.Selection.Find.Execute FindText:=textobuscar
            While ObjWord.Selection.Find.found = True
                ObjWord.Selection.Text = datos(1, i) 'texto a reemplazar
                ObjWord.Selection.Move 6, -1
                ObjWord.Selection.Find.Execute FindText:=textobuscar
            Wend
        Next i
        'para crear las tablas
        h1.Range("C37:G60").Select
        Selection.Copy
        textobuscar = "Copia_Cotizacion"
        ObjWord.Selection.Move 6, -1 'moverse al principio del documento
        ObjWord.Selection.Find.Execute FindText:=textobuscar
        While ObjWord.Selection.Find.found = True 'reemplaza el texto, y busca si hay otro para reemplazarlo
            ObjWord.Selection.PasteExcelTable False, True, False
            ObjWord.Selection.Move 6, -1
            ObjWord.Selection.Find.Execute FindText:=textobuscar
        Wend
        'tabla 2
        h1.Range("C5:F14").Select
        Selection.Copy
        textobuscar = "COPIA_CRONOGRAMA"
        ObjWord.Selection.Move 6, -1 'moverse al principio del documento
        ObjWord.Selection.Find.Execute FindText:=textobuscar
        While ObjWord.Selection.Find.found = True 'reemplaza el texto, y busca si hay otro para reemplazarlo
            ObjWord.Selection.PasteExcelTable False, True, False
            ObjWord.Selection.Move 6, -1
            ObjWord.Selection.Find.Execute FindText:=textobuscar
        Wend
    Next pl
    ObjWord.Activate
End Sub

Recuerda cambiar la valoración a la respuesta.

Después de esta línea

Set h1 = Sheets("Hoja2")

Agrega esta línea:

h1.Select

Recuerda cambiar la valoración a la respuesta.

¡Gracias! La verdad no se ni como agradecerte... solo me queda pendiente que cuando se ejecuta muestra la hoja de donde salen los datos y no quisiera eso, pero con lo que me ayudaste quede más que contenta... gracias... mil gracias

Un abrazo