Macro para copiar imágenes desde varias hojas de excel a w0rd
Los ejemplo que eme envío son muy bueno, pero la macro solo pega de una hoja de excel a word.
Esta macro quiero adaptarla para que inserte imágenes desde varias hojas de excel y la pegue en word, en este ejemplo las imágenes las tengo en la hoja suelos y en la hoja insertar mapas, la idea es que me pegue en word
Gracias por la ayuda
Sub CREAR_INFORME()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim objWord As Word.Application, wdDoc As Word.Document
Set A = Sheets(ActiveSheet.Name)
nom = ActiveWorkbook.Name
pto = InStr(nom, ".")
nomarch = Left(nom, pto - 1)
ruta = ThisWorkbook.Path & "\" & nomarch & ".docx"
Set objWord = CreateObject("Word.Application")
objWord.DisplayAlerts = wdAlertsNone
objWord.Visible = True
Set wdDoc = objWord.Documents.Open(ruta)
nomfic = nomarch & " " & Format(Date, "dd-mm-yyyy")
rutainf = ThisWorkbook.Path & "\" & nomfic & ".docx"
For x = 1 To ActiveSheet.Shapes.Count
Sheets("SUELOS").Activate
ActiveSheet.Shapes(x).CopyPicture
ts = "[TABLA" & x & "]"
Sheets("INSERTAR_MAPAS").Activate
ActiveSheet.Shapes(x).CopyPicture
ts = "[MAPA" & x & "]"
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=ts
While objWord.Selection.Find.Found = True
objWord.Selection.Paste ' False, True, False
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=ts
can = can + 1
Wend
Next x
wdDoc.SaveAs Filename:=rutainf, FileFormat:=wdFormatXMLDocument
'wdDoc.Close
MsgBox ("Se copiaron " & can & " gráficos de Excel a Word"), vbInformation, "AVISO"
'wdDoc.Quit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
1 respuesta
Revisa si lo siguiente es lo que necesitas:
Sub CREAR_INFORME()
Dim objWord As Word.Application, wdDoc As Word.Document
Dim nom As String, nomarch As String, ruta As String
Dim nomfic As String, rutainf As String, ts As String
Dim x As Long, can As Long
Dim hojas As Variant, h As Long
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
nom = ActiveWorkbook.Name
nomarch = Left(nom, InStr(nom, ".") - 1)
ruta = ThisWorkbook.Path & "\" & nomarch & ".docx"
nomfic = nomarch & " " & Format(Date, "dd-mm-yyyy")
rutainf = ThisWorkbook.Path & "\" & nomfic & ".docx"
'
'
Set objWord = CreateObject("Word.Application")
objWord.DisplayAlerts = wdAlertsNone
objWord.Visible = True
Set wdDoc = objWord.Documents.Open(ruta)
hojas = Array("SUELOS", "TABLA", "INSERTAR_MAPAS", "MAPA")
'
For h = 0 To UBound(hojas) Step 2
Sheets(hojas(h)).Select
For x = 1 To ActiveSheet.Shapes.Count
ActiveSheet.Shapes(x).CopyPicture
ts = "[" & hojas(h + 1) & x & "]"
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=ts
While objWord.Selection.Find.Found = True
objWord.Selection.Paste ' False, True, False
objWord.Selection.Move 6, -1
objWord.Selection.Find.Execute FindText:=ts
can = can + 1
Wend
Next x
Next h
'
wdDoc.SaveAs Filename:=rutainf, FileFormat:=wdFormatXMLDocument
'wdDoc.Close
MsgBox ("Se copiaron " & can & " gráficos de Excel a Word"), vbInformation, "AVISO"
'wdDoc.Quit
'
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Hola
Me funciona muy bien, una pregunta si en caso le quiero crear otras hojas funciona normal o que toca hacer.
Muchas gracias le agradezco por su maravillosa ayuda
En esta línea agregas la hoja y el nombre de los shapes
hojas = Array("SUELOS", "TABLA", "INSERTAR_MAPAS", "MAPA")
