Экспорт таблиц MS Word из многих текстовых документов в листы Excel

Question

Я ищу сценарий, который будет извлекать таблицу из каждого слова doc, которое у меня есть в папке, и помещать каждый результат таблицы в одну книгу/один рабочий лист в excel. У меня слишком много документов, чтобы делать их по одному. Мне также нужно, чтобы имя файла, из которого они были экспортированы, в последнем финальном столбце (столбец H/или столбец 9, при условии, что данные начинают импортироваться, начиная с столбца A/или столбца1)

Код, который я нашел, отлично работает, если вы делаете каждый документ по одному, но даже тогда он перезаписывает предыдущие данные в excel, когда вы запускаете его для следующего слова doc (см. ниже).

(то, что я использую сейчас ниже - у меня уходит целый день, чтобы пройти через одну папку)

Option Explicit 

Sub ImportWordTable() 
    Dim wdDoc As Object 
    Dim wdFileName As Variant 
    Dim tableNo As Integer 'table number in Word 
    Dim iRow As Long 'row index in Excel 
    Dim iCol As Integer 'column index in Excel 
    Dim resultRow As Long 
    Dim tableStart As Integer 
    Dim tableTot As Integer 

    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 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 
         Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text) 
        Next iCol 
        resultRow = resultRow + 1 
       Next iRow 
      End With 
      resultRow = resultRow + 1 
     Next tableStart 
    End With 
End Sub 

Answer 1

Read Ron De Bruin's web site на поиске последнюю пустую строку.

Sub ImportWordTable() 
Dim wdDoc As Object 
Dim wdFileName As Variant 
Dim tableNo As Integer 'table number in Word 
Dim iRow As Long 'row index in Excel 
Dim iCol As Integer 'column index in Excel 
Dim resultRow As Long 
Dim tableStart As Integer 
Dim tableTot As Integer 

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 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 

    On Error Resume Next 
    Rng = ActiveSheet.Range("A4").CurrentRegion 
    resultRow = Rng.Find(What:="*", _ 
        After:=Rng.Cells(1), _ 
        Lookat:=xlPart, _ 
        LookIn:=xlFormulas, _ 
        SearchOrder:=xlByRows, _ 
        SearchDirection:=xlPrevious, _ 
        MatchCase:=False).Row + 1 
    On Error GoTo 0 
    If resultRow < 4 Then 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 
        Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text) 
       Next iCol 
       resultRow = resultRow + 1 
      Next iRow 
     End With 
     resultRow = resultRow + 1 
    Next tableStart 
End With 

End Sub