Excel VBA outlook pasting range not working

Question

Im trying to make a macro so i can past an array of cells range into a document. But i cant make it work. I have tried to test diffrent codess and watched difffrent tutorials. This code seems to do evrything except paste it in to the email. If i manulay paste it it paste the last cell range that was copied to it seems it copy the range as it should.

Sub RangeToOutlook_Multi()

    'Declare Outlook Variables
    Dim oLookApp As Outlook.Application
    Dim oLookItm As Outlook.MailItem
    Dim oLookIns As Outlook.Inspector
    
    'Declare Word Variables
    Dim oWrdDoc As Word.Document
    Dim oWrdRng As Word.Range
    
    'Delcare Excel Variables
    Dim RngArray As Variant
    
    On Error Resume Next
    
    'Get the Active instance of Outlook if there is one
    Set oLookApp = GetObject(, "Outlook.Application")
    
        'If Outlook isn't open then create a new instance of Outlook
        If Err.Number = 429 Then
        
            'Clear Error
            Err.Clear
        
            'Create a new instance of Outlook
            Set oLookApp = New Outlook.Application
            
        End If
        
    'Create a new email
    Set oLookItm = oLookApp.CreateItem(olMailItem)
    
          
    'Create an array to hold ranges
    RngArray = Array(Sheet6.Range("A101:E112"), Sheet6.Range("G101:K111"))

    With oLookItm
    
        'Define some basic info of our email
        .To = "xyz@abc.com"
        .CC = "xyz@abc.com"
        .Subject = "Here are all of my Ranges"
        .Body = "Here are all the Ranges from my worksheet."
        
        'Display the email
        .Display
        
        
        
        'Get the Active Inspector
        Set oLookIns = .GetInspector
        
        'Get the document within the inspector
        Set oWrdDoc = oLookIns.WordEditor
        
      For Each Item In RngArray
        
            Item.Copy
            
            'Define the range, insert a blank line, collapse the selection.
            Set oWrdRng = oWrdDoc.Application.ActiveDocument.Content
                oWrdRng.Collapse Direction:=wdCollapseEnd
                
            'Add a new paragragp and then a break
            Set oWrdRng = oWdEditor.Paragraphs.Add
                oWrdRng.InsertBreak
                        
            'Paste the object.
            oWrdRng.PasteSpecial DataType:=wdPasteMetafilePicture
        
     Next
    
    End With
        
End Sub ```

Answer 1

In the code the oWrdRng object is overwritten in the loop:

 For Each Item In RngArray
        
            Item.Copy
            
            'Define the range, insert a blank line, collapse the selection.
            Set oWrdRng = oWrdDoc.Application.ActiveDocument.Content
                oWrdRng.Collapse Direction:=wdCollapseEnd
                
            'Add a new paragragp and then a break
            Set oWrdRng = oWdEditor.Paragraphs.Add
            oWrdRng.InsertBreak
                        
            'Paste the object.
            oWrdRng.PasteSpecial DataType:=wdPasteMetafilePicture
        
     Next

The Document.Paragraphs property returns a Paragraphs collection that represents all the paragraphs in the specified document. So, it seems you need to change the code in the following way:

 For Each Item In RngArray
        
            Item.Copy
            
            'Define the range, insert a blank line, collapse the selection.
            Set oWrdRng = oWrdDoc.Content
            oWrdRng.Collapse Direction:=wdCollapseEnd
                
            'Add a new paragragp and then a break
            Set oWrdRng = oWrdDoc.Paragraphs.Add
            oWrdRng.InsertBreak
                        
            'Paste the object.
            oWrdRng.PasteSpecial DataType:=wdPasteMetafilePicture
        
     Next

Finally, I'd recommend debugging the code first if something is not working as it should, so you could refer to the specific line of code if something fails unexpectedly.