Oi Pros, quero usar o VBA para copiar a tabela no word (2007) para o Excel (2007)?

Os detalhes são:
Minhas tabelas no Word é layout vertical, o que significa o nome do item é listado na coluna da esquerda, como o nome do cliente, conta n º, tipo de endereço de dados com o conteúdo listado à direita. Tenho muitos documentos de Word como este com cada cliente em um doc.

Gostaria de importá-los todos em um excel folha com o nome do item a ser colocado para a linha superior e tornar-se uma mesa horizontal. Por favor me ajude aqui. Muitos muitos agradecimentos.

Resposta

Primeiro, certifique-se de incluir uma referência ao "Microsoft Excel 12.0 Object Library" em ferramentas > referências.

Aqui é uma macro que cria uma nova pasta de trabalho e copia o texto de todas as tabelas para Sheet1 transposição como vai:

Sub CopyTablesToExcel()

Dim tbl como Word

Dim trow como Word.row

Dim cel como Word.Cell

Dim rng As Word. Range

Dim wbk como Excel.Workbook

Dim sht As Excel. Worksheet

Dim xlApp As New Excel. Application

Dim lngRow As Long

Dim lngCol As Long

Dim intTbl As Integer

Definir wbk = xlApp.Workbooks.Add

Definir sht = wbk.Sheets(1)

intTbl = 1

lngCol = 1

Para cada tbl em ActiveDocument.Tables

Para cada trow na tbl.Linhas

lngRow = 1

Para cada cel em trow.Células

Com cel.Gama

shtCélulas (lngRow, lngCol).Valor = Left (.Texto, Len (.Texto) - 2)

Terminar com

lngRow = lngRow + 1

Próximo cel

lngCol = lngCol + 1

Trow próxima

intTbl = intTbl + 1

Próximo tbl

xlApp.Visible = True

End Sub

Se você preferir ter cada tabela na própria planilha aqui é uma versão ligeiramente diferente:

Sub CopyTablesToExcelMultiSheets()

Dim tbl como Word

Dim trow como Word.row

Dim cel como Word.Cell

Dim rng As Word. Range

Dim wbk como Excel.Workbook

Dim sht As Excel. Worksheet

Dim xlApp As New Excel. Application

Dim lngRow As Long

Dim lngCol As Long

Dim intTbl As Integer

Definir wbk = xlApp.Workbooks.Add

intTbl = 1

Para cada tbl em ActiveDocument.Tables

lngCol = 1

Definir sht = wbk.Sheets.Add (wbk.Sheets("Sheet1"))

shtNome = "Tabela" & intTbl

Para cada trow na tbl.Linhas

lngRow = 1

Para cada cel em trow.Células

Com cel.Gama

shtCélulas (lngRow, lngCol).Valor = Left (.Texto, Len (.Texto) - 2)

Terminar com

lngRow = lngRow + 1

Próximo cel

lngCol = lngCol + 1

Trow próxima

intTbl = intTbl + 1

Próximo tbl

xlApp.Visible = True

End Sub

Espero que ajude...