Copy images from Excel to header of Word

Hello,

I have a multiple sheets excel than I transform into a word via VBA.

On one of the sheets are two pictures, those two pictures i'd like to copy them in the header of the word document. One picture on the left-side and the other one on the right-side.

How could I do this ?

Thanks in advance for your help

Without access to the workbook it's something of a step in the dark, but the following could work. As you know the worksheet name, you could set that for xlSheet instead of looping through all the sheets to find a sheet with two shapes.

Code:

---

Option Explicit

Sub Macro1()
Dim xlapp As Object
Dim xlbook As Object
Dim xlSheet As Object
Dim oShape As Object
Dim oWdShape As InlineShape
Dim oRng As Range
Const strSource As String = "C:\Path\Workbook.xlsx" 'the name of the workbook
    On Error Resume Next
    Set xlapp = GetObject(, "Excel.Application")
    If Err Then
        Set xlapp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    Set xlbook = xlapp.workbooks.Open(strSource)
    For Each xlSheet In xlbook.worksheets
        If xlSheet.Shapes.Count = 2 Then
            Set oShape = xlSheet.Shapes(1)
            oShape.Copy
            Set oRng = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
            oRng.Collapse 1
            oRng.PasteSpecial link:=False, _
                              DataType:=14, _
                              Placement:=wdInLine, _
                              DisplayAsIcon:=False
            Set oRng = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
            Set oWdShape = oRng.InlineShapes(1)
            Set oShape = xlSheet.Shapes(2)
            oShape.Copy
            oRng.Start = oWdShape.Range.End + 1
            oRng.Text = vbTab & vbTab
            oRng.Collapse 0
            oRng.PasteSpecial link:=False, _
                              DataType:=14, _
                              Placement:=wdInLine, _
                              DisplayAsIcon:=False
            Exit For
        End If
    Next xlSheet
End Sub

---

Thank you for your answer !

Is it possible to have it shorter ? As the code is pretty long I try to find ways to make less code lines.

Here below is a code that I just tried for one picture :

'Copy the image in the excel sheet
Shapes.Range(Array("Group5")).Copy
'Paste it on the word document header
docWord.Sections(1).Headers(1).Range.Paste

However I got the error message 424 : Object Required

Do you know how I could fix it ? Is that a good approach to do it with less lines ?

Thanks !

Kind regards,

Christophe

You fix it by using the longer code. :)

Thanks ! I tried your code and I get a type mismatch with the line Set oRng = ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range

I tried changing oRng into a Variant. I did not get this type mismatch error however when I run the code it crashes the word application. Any idea How I could fix this ?

As a complement, I identified the bug occurs at the following line : oRng.PasteSpecial

It works fine now, Not sure what has changed but thanks a lot for your help !