CODEWITHSUNDEEP
vbaexcel
user2292821
user2292821

Reputation: 87

Copy Multiples Excel Ranges with VBA to Word as figures

Hi all i´m very new to VBA i´m struggling with a macro i´m trying to create. I want to copy paste as figures to a word file multiples ranges from Excel.

This is the code i´ve come up with:

Sub imagem1()
    Dim objWord, objDoc As Object
    ActiveWindow.View = xlNormalView
    Worksheets(2).Range("A1:O47").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Add
    objWord.Visible = True
    objWord.Selection.Paste
    objWord.Selection.TypeParagraph
    ActiveWindow.View = xlPageBreakPreview

End Sub

Sub imagem2()
    Dim objWord, objDoc As Object
    ActiveWindow.View = xlNormalView
    Worksheets(2).Range("U1:AI47").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Add
    objWord.Visible = True
    objWord.Selection.Paste
    objWord.Selection.TypeParagraph
    ActiveWindow.View = xlPageBreakPreview
End Sub

Sub imagem3()
    Dim objWord, objDoc As Object
    Worksheets(4).Activate
    ActiveWindow.View = xlNormalView
    Worksheets(4).Range("A1:Q47").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Add
    objWord.Visible = True
    objWord.Selection.Paste
    objWord.Selection.TypeParagraph
    ActiveWindow.View = xlPageBreakPreview
End Sub

The problem i´m having is that it will create three different word files with one image each. I would like to know how can i code it so it will paste the 3 images to the same word file.

I would also like to make it not creating a new word file every time i used the macro but instead copy the 3 images to an already opened word file where the cursor is.

Thanks a lot for the help.

Upvotes: 0

Views: 318

Answers (1)

Tim Williams
Tim Williams

Reputation: 166755

Tested (changed the ranges for my testing):

Sub imagem1()

    Dim objWord As Object, objDoc As Object, Rng As Object
    Dim wb As Workbook

    Set wb = ActiveWorkbook

    'see if Word is already open
    On Error Resume Next
    Set objWord = GetObject(, "Word.Application")
    On Error GoTo 0

    'not open - create a new instance and add a document
    If objWord Is Nothing Then
        Set objWord = CreateObject("Word.Application")
        objWord.Visible = True
        objWord.documents.Add
    End If

    Set objDoc = objWord.activedocument
    Set Rng = objWord.Selection

    wb.Windows(1).View = xlNormalView

    wb.Worksheets(1).Range("A1:C5").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Rng.Paste
    Rng.typeparagraph

    wb.Worksheets(1).Range("A7:C12").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Rng.Paste
    Rng.typeparagraph

    wb.Worksheets(1).Range("A14:C19").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Rng.Paste
    Rng.typeparagraph

End Sub

Upvotes: 1

Related Questions