Importing Multiple Word Documents Into Excel

Do these imported tables all go onto the same worksheet (in which case you presumably want only one set of header rows), or onto separate worksheets? If all go onto the same worksheet then, given that table 3 has 3 data rows, what is supposed to happen regarding the lack of data for the corresponding Excel rows for tables 1 & 2? Given that What kind of data are in the cells (e.g. a single paragraph or multiple paragraphs), and is there formatting such as bold, underline, etc. you need to preserve?

For what you've described, the following should suffice:

Sub GetData()
Application.ScreenUpdating = False
Dim StrFolder As String, StrFile As String, StrFnd As String
Dim wdApp As Object, wdDoc As Object, bStrt As Boolean
Dim WkSht As Worksheet, LRow As Long, i As Long, j As Long
StrFolder = GetFolder
If StrFolder = "" Then Exit Sub
Set WkSht = ThisWorkbook.Sheets("Sheet1")
LRow = WkSht.Range("A" & WkSht.UsedRange.Rows.Count).End(xlUp).Row
' Test whether Word is already running.
On Error Resume Next
bStrt = False ' Flag to record if we start Word, so we can close it later.
Set wdApp = GetObject(, "Word.Application")
'Start Excel if it isn't running
If wdApp Is Nothing Then
  Set wdApp = CreateObject("Word.Application")
  If wdApp Is Nothing Then
    MsgBox "Can't start Word.", vbExclamation
    Exit Sub
  End If
  ' Record that we've started Word.
  bStrt = True
End If
On Error GoTo 0
StrFile = Dir(StrFolder & "\*.doc")
While StrFile <> ""
  LRow = LRow + 1
  Set wdDoc = wdApp.Documents.Open(Filename:=StrFolder & "\" & StrFile, AddToRecentFiles:=False, Visible:=False, ReadOnly:=True)
  With wdDoc
    'Get the data for each table
    With .Tables(1)
      For i = 1 To 3
        WkSht.Cells(LRow, i).Value = Split(.Cell(2, i).Range.Text, vbCr)(0)
      Next
    End With
    With .Tables(2)
      For i = 1 To 4
        WkSht.Cells(LRow, i + 3).Value = Split(.Cell(2, i).Range.Text, vbCr)(0)
      Next
    End With
    With .Tables(3)
      For i = 1 To 3
        WkSht.Cells(LRow, i + 7).Value = Split(.Cell(2, i).Range.Text, vbCr)(0)
        WkSht.Cells(LRow, i + 10).Value = Split(.Cell(3, i).Range.Text, vbCr)(0)
        WkSht.Cells(LRow, i + 13).Value = Split(.Cell(4, i).Range.Text, vbCr)(0)
      Next
    End With
    'Close without saving changes
    .Close SaveChanges:=False
  End With
  StrFile = Dir()
Wend
If bStrt = True Then wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = 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

The macro includes a folder browser, so all you need do is select the folder concerned.

Note: The macro will fail if the folder contains a document not containing the three tables you described as the first three tables in it.

Each time you run the macro, it starts adding data immediately after the last existing used row. If you re-run it with the same data files in the folder that you used on a previous data, those same files will be added again after the existing data; the existing data won't be replaced. I've just re-tested and confirmed that's what it's doing.

If you want to avoid duplicates, either:
• wait until you have all the data before importing
• clear all the existing data before re-importing
• use a temporary folder to hold files that have not yet been imported, do the import from that folder, then move the imported files to another folder.

As I said before, the macro does not replace any data.

Ok. To make sure I am doing something right and not wrong, I will list the steps and the results.

I have a folder with 10 docs.
The spreadsheet contains one row of headers.
I run the macro on the directory and all 10 docs appear perfectly.

I modify some details in the doc and duplicate it 10 times and put it in another directory. I delete the other 10, so there is 10 "new" files.
I run the script and all the rows used (2 to 11 in this case) update with the new data, overriding the old.

I've put the macro in a module in the workbook, not in my personal macro workbook.

Is this how it is supposed to work?

The solution would be to create 2 tabs, one for the temp drop of data and another with the live data. Then just cut'n'paste.
Sorry if I am being dumb here.

Edit: Bizarrely if I take the 10 rows of data and move them down to like row 30 and run it again, it replaces the data in the rows with data only. Rows 2 to 29 remain empty.

Edit 2: Well I dunno what happened. I deleted all the rows of data and tried it once more. Now it works exactly like you said it does. Puzzling.

But as I said, we can always move the data over after running it. So it has saved us a long tedious task. Thanks so much!

The macro was written to be run from the workbook you're populating, not from some other workbook (including your personal macro workbook). The 'ThisWorkbook' reference means the macro is trying to update your personal macro workbook, which I'm sure is not what you want to happen. If you want to run the macro from your personal macro workbook, change the 'ThisWorkbook' reference to 'ActiveWorkbook'.

Change:

    With .Tables(3)
      For i = 1 To 3
        WkSht.Cells(LRow, i + 7).Value = Split(.Cell(2, i).Range.Text, vbCr)(0)
        WkSht.Cells(LRow, i + 10).Value = Split(.Cell(3, i).Range.Text, vbCr)(0)
        WkSht.Cells(LRow, i + 13).Value = Split(.Cell(4, i).Range.Text, vbCr)(0)
      Next
    End With

to:

    With .Tables(3)
      For i = 1 To 2
        WkSht.Cells(LRow, i + 7).Value = Split(.Cell(2, i).Range.text, vbCr)(0)
      Next
    End With
    With .Tables(4)
      For i = 1 To 4
        WkSht.Cells(LRow, i + 9).Value = Split(.Cell(i, 2).Range.text, vbCr)(0)
      Next
    End With