Alguma ideiaaa?

Meu forte não é a integração com o Word, estou mexendo um pouco só para ajudar um pessoal aqui no serviço, ainda estou engatinhando, mas pelo que entendi, acredito que os link abaixo já de uma luz, veja se consegue ir ajustando.

Copy & Paste An Excel Table Into Microsoft Word With VBA
https://www.thespreadsheetguru.com/blog ... d-with-vba

Copy & Paste Multiple Excel Tables Into Microsoft Word With VBA
https://www.thespreadsheetguru.com/blog ... 20Table%20

[]s

Boa Tarde Mauro

Obrigado Pelo Link
Estou com problemas pra declara a planilha

nessa linha ele nao identifica a planilha pra copia os dados

Set tbl = ThisWorkbook.Worksheets(Sheet1.Name).ListObjects("mj").Range

como deveria usa?

Att Vitor hugo

Faltou as aspas " " no nome da planilha

Set tbl = ThisWorkbook.Worksheets(Sheets(1).Name).ListObjects("mj").Range

Notei que você não usa "r" no final de verbos: clicar, ajudar, usar, copiar, declarar

Se copiou a rotina do site, a instrução está correta :

Set tbl = ThisWorkbook.Worksheets(Sheet1.Name).ListObjects("mj").Range

Acredito que o erro se dá por você estar usando Excel em portugues, e a rotina indicada utiliza excel em ingles, então é só trocar Sheet1 por Plan1:

Set tbl = ThisWorkbook.Worksheets(Plan1.Name).ListObjects("mj").Range

Editando :
Li rapidamente. você citou sobre Declarar a planilha, mas não mostrou se a mensagem de erro é referente a planilha ou ao "ListObjects", eu comentei sobre a referência à aba, e esqueci de comentar que a rotina indicada no site se refere a TABELAS e não Ranges, então, ou nomeie seus range e ajuste a rotinas ou converta para tabelas, alem de ajustar o nome da aba.

[]s

Boa Tarde Familia

Testei todos as soluçoes dadas mais ainda estou com erro 9 sub inscrição fora de intervalo
Set tbl = ThisWorkbook.Worksheets("Plan10.Name").ListObjects("FUNAD").Range
se eu comenta o cod nao da erro oque estou fazendo de errado?

Primeiro: no modelo que anexou, você não tem "Plan10" :
Set tbl = ThisWorkbook.Worksheets("Plan10.Name").ListObjects("FUNAD").Range,

Segundo: Tem 3 regiões com dados, e pela linha irá copiar só uma ".ListObjects("FUNAD").Range", esta região você converteu para Tabela e renomeou ? Ou só criou um Range nomeado ?

Terceiro : Nas postagens anteriores, você citou "ListObjects("mj")", agora é outro nome ? É outra Tabela ?

Nos links que indiquei tem os modelos prontos para baixar, baixe e veja as diferenças.

[]s

Boa tarde

Obrigado por me auxiliar Mauro

Primeiro: no modelo que anexou, você não tem "Plan10" :
Set tbl = ThisWorkbook.Worksheets("Plan10.Name").ListObjects("FUNAD").Range,

R Testei em outra planilha com outro nome por isso mudei a plan e o nome

Segundo: Tem 3 regiões com dados, e pela linha irá copiar só uma ".ListObjects("FUNAD").Range", esta região você converteu para Tabela e renomeou ? Ou só criou um Range nomeado ?

R Não mudei pra tabela somente renomeei a "sheets" para FUNAD ou como no primeiro modelo Mj como faço pra converte em tabela?

Terceiro : Nas postagens anteriores, você citou "ListObjects("mj")", agora é outro nome ? É outra Tabela ?

R Tava fazendo testes por isso troquei o nome e a sheets

Nos links que indiquei tem os modelos prontos para baixar, baixe e veja as diferenças.

R Nao conseguir baixa os arquivos =/

Att, Vitor Hugo

Primeiro :
Set tbl = ThisWorkbook.Worksheets("Plan10.Name").ListObjects("FUNAD").Range
Não é para renomear a Sheet e sim o Range que será copiado e cada um tem de ter um nome, nesta instrução a ABA(Worksheets) tem o nome "Plan10" e o Range ou a Tabela "FUNAD".

Se tem 3 Regiões, está utilizando a instrução para se copiar sómente uma, Set tbl = ThisWorkbook.Worksheets("Plan10.Name").ListObjects("FUNAD").Range, não utilizou a rotina do outro link em que é feito o Loop em várias tabelas.

Para se converter em Tabela, selecione a região com Dados, selecione a Aba Inserir e clique em Tabela, faça isto em cada região para se criar as 3 Tabelas, e como na rotina está definido "Table1,..2.. e 3" ou renomeie as tabelas ou ajuste na rotina conforme os nomes criados.

Veja seu modelo convertido em tabelas, nesta rotina o arquivo Word tem de estar aberto, não mexi na parte de formatação no word, mas isto é só pesquisar aqui no forum.

Se for utilizar Ranges NOMEADOS, use a rotina abaixo :

Option Base 1 'Force arrays to start at 1 instead of 0

Sub ExcelTablesToWord()

'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
'NOTE: Must have Word Object Library Active in Order to Run _
  (VBE > Tools > References > Microsoft Word 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com

    Dim WordApp As Word.Application
    Dim myDoc As Word.Document
    Dim WordTable As Word.Table
    Dim BookmarkArray As Variant
    Dim x As Integer

    'List of Word Document Bookmarks (To Paste To)
    BookmarkArray = Array("Bookmark1", "Bookmark2", "Bookmark3")

    'Optimize Code
      Application.ScreenUpdating = False
      Application.EnableEvents = False

    'Set Variable Equal To Destination Word Document
    On Error GoTo WordDocNotFound
      Set WordApp = GetObject(class:="Word.Application")
      WordApp.Visible = True
      Set myDoc = WordApp.Documents("Excel Table Word Report.docx")
    On Error GoTo 0
    
    'Nomeie os RANGES antes e use as linhas abaixo
    'Loop nos Ranges NOMEADOS Copia e Cola
    For x = 1 To ActiveWorkbook.Names.Count
        
        'Armazena os nomes de cada Range
        sTbl = ActiveWorkbook.Names(x).Name
        'Copia os Ranges Nomeados
        Range(sTbl).Copy
    
        'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
         myDoc.Bookmarks(BookmarkArray(x)).Range.PasteExcelTable _
         LinkedToExcel:=False, WordFormatting:=False, RTF:=False
    
        'Autofit Table so it fits inside Word Document
          Set WordTable = myDoc.Tables(x)
          WordTable.AutoFitBehavior (wdAutoFitWindow)

  Next x

    'Completion Message
      MsgBox "Copy/Pasting Complete!", vbInformation
      GoTo EndRoutine
      
    'ERROR HANDLER
WordDocNotFound:
      MsgBox "Microsoft Word file 'Excel Table Word Report.docx' is not currently open, aborting.", 16
    
    'Put Stuff Back The Way It Was Found
EndRoutine:
    'Optimize Code
      Application.ScreenUpdating = True
      Application.EnableEvents = True
    
    'Clear The Clipboard
      Application.CutCopyMode = False

End Sub

[]s

Boa Tarde Mauro Conseguir

pra efetua a colagem como imagem teria que muda qual parte
ta colando com formatação grande mais era isso mesmo
muito obrigado pela ajuda

Neste mesmo modelo que enviei, para copiar como figura e colar no word, utilize a rotina abaixo.

Sub ExcelCopyToWordComoFigura()

'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
'NOTE: Must have Word Object Library Active in Order to Run _
  (VBE > Tools > References > Microsoft Word 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com

Dim tbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim TableArray As Variant
Dim BookmarkArray As Variant

'List of Table Names (To Copy)
  TableArray = Array("Table1", "Table2", "Table3")
  
'List of Word Document Bookmarks (To Paste To)
  BookmarkArray = Array("Bookmark1", "Bookmark2", "Bookmark3")

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

'Set Variable Equal To Destination Word Document
  On Error GoTo WordDocNotFound
    Set WordApp = GetObject(class:="Word.Application")
    WordApp.Visible = True
    Set myDoc = WordApp.Documents("Excel Table Word Report.docx")
  On Error GoTo 0
    
'Loop Through and Copy/Paste Multiple Excel Tables
  For x = LBound(TableArray) To UBound(TableArray)

    'Copy Table Range from Excel
      Set tbl = ThisWorkbook.Worksheets(1).ListObjects(TableArray(x)).Range
      
      'Copia como Figura
      tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
      myDoc.Bookmarks(BookmarkArray(x)).Range.Paste

  Next x
'Completion Message
  MsgBox "Copy/Pasting Complete!", vbInformation
  GoTo EndRoutine
  
'ERROR HANDLER
WordDocNotFound:
  MsgBox "Microsoft Word file 'Excel Table Word Report.docx' is not currently open, aborting.", 16

'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub

[]s

Tentei utiliza essa rotina de cima porem
deu esse erro Word File excel table word report.docx is not corruntly open aborting

conseguir roda com essa rotina mais nao ta copiando com a formatação de IMG

Sub ExcelRangeToWord()


Dim tbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table


  Application.ScreenUpdating = False
  Application.EnableEvents = False

With tbl

 Set tbl = ThisWorkbook.Worksheets(Plan1.Name).ListObjects("Tabela1").Range
tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture

 End With
  On Error Resume Next
    
          Set WordApp = GetObject(class:="Word.Application")
    
   
      Err.Clear

   
      If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
    
  
      If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
      End If

  On Error GoTo 0
  

  WordApp.Visible = True
  WordApp.Activate

  Set myDoc = WordApp.Documents.Add
  

  tbl.Copy
 'tbl.CopyPicture xlScreen, xlBitmap

  myDoc.Paragraphs(1).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False


  Set WordTable = myDoc.Tables(1)
  WordTable.AutoFitBehavior (wdAutoFitWindow)
   
EndRoutine:

  Application.ScreenUpdating = True
  Application.EnableEvents = True


  Application.CutCopyMode = False

End Sub