Import table data multiple .doc files into Excel, including filenames

[Frooga]

I found the following script that works perfectly for me, in terms of extracting the data from .doc file table and getting it into a single row in Excel.


I need to modify this to:


1. Open and parse multiple .doc files residing in the same folder. It would be awesome if I can select the folder when I execute the routine.
2. include the .doc original filename for each line of data in the Excel file.


There is only one table per file which contains 5 columns, number of rows vary from file to file. I'd like the filename to be in column 6 of the Excel sheet.


I've tried a few things and am failing horribly! Any help would be greatly appreciated.

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
    
    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
        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 table number of table to import", "Import Word Table", "1")
        End If
        With .tables(TableNo)
            'copy cell contents from Word table cells to Excel cells
            For iRow = 1 To .Rows.Count
                For iCol = 1 To .Columns.Count
                    Cells(iRow, iCol) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
                Next iCol
            Next iRow
        End With
    End With
    
    Set wdDoc = Nothing
    
    End Sub

 

[Macropod]

Try the following Excel macro, which allows you to choose the source folder. The macro outputs the first table for each document one below the other, with an empty row in between. Except for text wrapping, table formatting is preserved as much as possible.

Sub GetFirstTableData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFolder As String, strFile As String, r As Long
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    With .Tables(1)
      With .Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "[^13^l]"
        .Replacement.Text = Chr(182)
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
      End With
      .Columns.Add
      .Cell(1, 6).Range.Text = Split(strFile, ".doc")(0)
      .Range.Copy
    End With
    With ActiveSheet
      r = .Cells(.Rows.Count, 1).End(xlUp).Row
      If r > 1 Then r = r + 2
      .Paste Destination:=.Range("A" & r)
    End With
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
ActiveSheet.UsedRange.Replace What:=Chr(182), Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

 

[Frooga]

THANK YOU SO MUCH! This works like a dream!