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 Sub
Tras 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