Извлечение таблиц слов в отдельные таблицы Excel с использованием кода VBA

Question

У меня есть текстовый документ с 278 таблицами, и мне нужно извлечь 278 таблиц в разные рабочие листы Excel. Также мне нужно извлечь ключевое слово из файла описания заголовка для именования рабочих листов

У меня есть код VBAв Excel, чтобы извлечь таблицы файлов слов в один лист Excel.

  Sub ImportWordTable()

          Dim wdDoc As Object
          Dim wdFileName As Variant
          Dim tableNo As Long 'table number in Word
          Dim iRow As Long 'row index in Excel
          Dim iCol As Long 'column index in Excel
          Dim resultRow As Long
          Dim tableStart As Long
          Dim tableTot As Long
          Dim wkSht As Worksheet

  On Error Resume Next
      wdFileName = Application.GetOpenFilename("Word files (*.doc),*.doc", , _
   "Browse for file containing table to be imported")

  If wdFileName = False Then Exit Sub '(user cancelled import file browser)
  Set wkSht = ActiveSheet
wkSht.Range("A:AZ").ClearContents

Set wdDoc = GetObject(wdFileName) 'open Word file

    With wdDoc
tableNo = wdDoc.Tables.Count
tableTot = wdDoc.Tables.Count
If tableNo = 0 Then
  MsgBox "This document contains no tables", _
    vbExclamation, "Import Word Table"
ElseIf tableNo > 1 Then
  tableNo = InputBox("This Word document contains " & tableNo & " tables." & vbCrLf & _
    "Enter the table to start from", "Import Word Table", "1")
End If
resultRow = 4

For tableStart = 1 To tableTot
  With .Tables(tableStart)
    'copy cell contents from Word table cells to Excel cells
    For iRow = 1 To .Rows.Count
      For iCol = 1 To .Columns.Count
        wkSht.Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
      Next iCol
      resultRow = resultRow + 1
    Next iRow
  End With
  resultRow = resultRow + 1
  With wkSht
    .Range(.Cells(resultRow, 1), .Cells(resultRow, iCol)).Interior.ColorIndex = 15
  End With
  resultRow = resultRow + 1
Next tableStart
   End With

End Sub

Я хотел бы изменить код, чтобы я мог получить каждую таблицу в отдельном листе Excel.

Answer 1

Это не решит вашу конкретную проблему с переименованием листов. Тем не менее, я думаю, что как только у вас есть данные в Excel, вы можете использовать некоторые VBA, чтобы перебрать листы, чтобы выполнить процесс переименования. Вот код Word VBA (запускается из Word) для перевода каждой таблицы из Word в Excel на новом листе.

Option Explicit

'Run this from Word VBA
Public Sub GetTables()
    Dim Table      As Table
    Dim Doc        As Document: Set Doc = ThisDocument
    Dim xl         As Object: Set xl = CreateObject("Excel.Application")
    Dim wb         As Object: Set wb = xl.Workbooks.Add
    Dim ws         As Object

    For Each Table In Doc.Tables
        Table.Range.Copy
        Set ws = wb.Sheets.Add()
        ws.Paste
    Next

    xl.Visible = True
    wb.Save
End Sub