Hoy veremos un sencillo código para traspasar, mediante macros, una imagen desde nuestra hoja de cálculo a un documento de Word (insertado en una Tabla).
De especial en este ejemplo, es que generamos una Tabla en nuestro documento de Word, en la cual insertamos la imagen.
Además verificaremos si existe el fichero .docx o no, tomando el nombre del fichero de la celda G1.
Tenemos la siguiente imagen superpuesta en un rango de celdas... la idea es seleccionar el rango y copiarlo como imagen, para luego copiar y pegarlo en un documento de Word.
Insertamos el código asociado al control CommandButton y ejecutamos el siguiente procedimiento:
Tras ejecutar el proceso veremos nuestro documento Word:
NOTA: es importante activar/habilitar la referencia 'Microsoft Word 15.0 Object Library'
De especial en este ejemplo, es que generamos una Tabla en nuestro documento de Word, en la cual insertamos la imagen.
Además verificaremos si existe el fichero .docx o no, tomando el nombre del fichero de la celda G1.
Tenemos la siguiente imagen superpuesta en un rango de celdas... la idea es seleccionar el rango y copiarlo como imagen, para luego copiar y pegarlo en un documento de Word.
Insertamos el código asociado al control CommandButton y ejecutamos el siguiente procedimiento:
Private Sub CommandButton1_Click()
'con la referencia Microsoft Word 15.0 Object Library
Dim tabla As Object
'copiamos el rango de la hoja de cálculo
Sheets("ExcelToWord").Select
Range("B1:E11").CopyPicture xlScreen, xlPicture
'definimos la ruta destino del documento de Word
'tomando como nombre de docx el valor de la celda G1
Dim archivo As String
archivo = "E:\excelforo\" & Range("G1") & ".docx"
'Creamos el documento
Set objWord = CreateObject("Word.Application")
'y lo hacemos visible
objWord.Visible = True
'verificamos si existe o no un .docx con ese nombre (celda G1)
With objWord
If Dir(archivo) = "" Then
'si no existe lo añadimos nuevo
Set objDoc = objWord.Documents.Add
objDoc.SaveAs (archivo)
Else
'si existe lo abrimos
Set objDoc = .Documents.Open(archivo)
End If
End With
'generamos una Tabla en el documento de Word
Set tabla = objDoc.Tables.Add(objDoc.Range, 1, 1)
'y pegamos en la celda 'A1' de la tabla de Word la imagen
tabla.cell(1, 1).Range.Paste
'acabamos guardando el Word
objDoc.Save
Set tabla = Nothing
End SubTras ejecutar el proceso veremos nuestro documento Word:
NOTA: es importante activar/habilitar la referencia 'Microsoft Word 15.0 Object Library'




Excelente aporte. Mil gracias.
ResponderEliminary en el caso en el que se esté trabajando en Word, y de Woed se quiera obtener la imagen de Excel, y mostrarla en Word, cómo se haría?
ResponderEliminarMuchas Gracias de Antemano.
Hola Miguel,
Eliminardebe ser algo similar... por desgracias no soy exporto en VBA para Word y no puedo ayudarte demasiado.
Emplea el asistente de grabación de macros en Word.. quizá obtengas algo de código que te ayudará.
Puedes buscar en foros especializados en Word.
Suerte!!
quisiera poner más tablas pero no sé como separarlas, intenté esto pero me deja la última tabla
ResponderEliminarset tabla2 = objDoc.Tables.Add(objDoc.Range, 1, 1)
tabla2.cell(1, 1).Range.Paste
tengo un problema, quiero pasar tablas de varias hojas a una plantilla de word, y no logro hacerlo, tengo este codigo para pasar de algunas celdas a word.
ResponderEliminarPrivate Sub CommandButton1_Click()
Dim datos(0 To 1, 0 To 20) As String ' (columna,fila)
patharch = ThisWorkbook.Path & "\MUESTRA.dotm"
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.documents.Add Template:=patharch, NewTemplate:=False, DocumentType:=0
datos(0, 0) = "[A1]"
datos(1, 0) = Hoja2.Cells(5, 2) '(fila,columna)
datos(0, 1) = "[A2]"
datos(1, 1) = Hoja2.Cells(6, 2)
datos(0, 2) = "[A3]"
datos(1, 2) = Hoja2.Cells(7, 2)
datos(0, 3) = "[B1]"
datos(1, 3) = Hoja3.Cells(4, 2)
datos(0, 4) = "[B2]"
datos(1, 4) = Hoja3.Cells(5, 2)
datos(0, 5) = "[B3]"
datos(1, 5) = Hoja3.Cells(6, 2) '(fila,columna)
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
objWord.Activate
End Sub
Hola Amilcar,
Eliminarpor favor, lee las Normas de uso del blog, y si procede envíame un email donde se indica
Saludos