Boa tarde,

Veja se esta adaptação do seu código atende:

Sub GerarRelatorio()
   
    Sheets("Relatorio").Activate
    Dim objWord As Variant
    Dim Intervalo As Range

    Set Intervalo = Range("A1:G10")
    Intervalo.Copy
    
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    With objWord
        .Documents.Add Template:="Normal", newtemplate:=False, DocumentType:=0
        .Selection.PasteExcelTable False, False, False
        .Selection.TypeParagraph
        .ActiveDocument.SaveAs Filename:="Relatório.doc", FileFormat:= _
        0, LockComments:=False, Password:="", AddToRecentFiles:= _
        True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
        False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
    End With
    Set objWord = Nothing
End Sub

Abraço

Perfeitamente Mestre JValq.

Obrigado
Abraço.

JValq.

Tem Alguma possibilidade dessa macro copiar todos os outros objeto da planilha e não copiar as linhas de grade do Excel?

Aguardo retorno.

Boa noite,

Quais objetos?
Quanto à grade, se o intervalo copiado não tiver bordas a tabela vai ser copiada desta maneira.

Abraço

Bom dia.

Seria uma imagem e algumas caixas de textos.

Aguardo retorno.

Bom dia,

Supondo que sejam 4 objetos, veja se o código abaixo atende:

Sub GerarRelatorio()
   
    Sheets("Relatorio").Activate
    Dim objWord As Variant
    Dim Intervalo As Range

    Set Intervalo = Range("A1:G10")
    Intervalo.Copy
    
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    With objWord
        .Documents.Add Template:="Normal", newtemplate:=False, DocumentType:=0
        .Selection.PasteExcelTable False, False, False
        .Selection.TypeParagraph
        .ActiveDocument.SaveAs Filename:="Relatório.doc", FileFormat:= _
        0, LockComments:=False, Password:="", AddToRecentFiles:= _
        True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
        False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
    End With
    
    ActiveSheet.Shapes.Range(Array(1, 2, 3, 4)).Select
    Selection.Copy
    objWord.Selection.Paste
    
    Set objWord = Nothing
End Sub

Abraço

Para qualquer quantidade de objetos:

Sub GerarRelatorio()
   
    Sheets("Relatorio").Activate
    Dim objWord As Variant
    Dim Intervalo As Range

    Set Intervalo = Range("A1:G10")
    Intervalo.Copy
    
    Set objWord = CreateObject("Word.Application")
    objWord.Visible = True
    With objWord
        .Documents.Add Template:="Normal", newtemplate:=False, DocumentType:=0
        .Selection.PasteExcelTable False, False, False
        .Selection.TypeParagraph
        .ActiveDocument.SaveAs Filename:="Relatório.doc", FileFormat:= _
        0, LockComments:=False, Password:="", AddToRecentFiles:= _
        True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
        False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
    End With
    
    ActiveSheet.DrawingObjects.Copy
    objWord.Selection.Paste
    
    Set objWord = Nothing
End Sub

Abraço

Ficou otimo.

Obrigado mais uma vez!.

Abraço.