Macro para copiar imágenes desde varias hojas de excel a w0rd

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