Maybe something like the following, which also produces a log of the documents processed and the number of tables extracted.
Code:
Option Explicit
Sub BatchCopyTables()
'Graham Mayor - http://www.gmayor.com - Last updated - 06/05/2017
Dim strFileName As String
Dim strPath As String
Dim oDoc As Document, oNewDoc As Document
Dim oTable As Range, oRng As Range
Dim oLog As Document
Dim bFound As Boolean
Dim fDialog As FileDialog
Dim oColl As New Collection
Dim i As Long, j As Long, k As Long
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select folder and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , _
"List Folder Contents"
GoTo lbl_Exit
End If
strPath = fDialog.SelectedItems.Item(1) & Chr(92)
End With
Set oNewDoc = Documents.Add
strFileName = Dir$(strPath & "*.doc")
While Len(strFileName) <> 0
Set oDoc = Documents.Open(FileName:=strPath & strFileName, AddtoRecentFiles:=False)
bFound = False
If oDoc.ProtectionType = wdNoProtection Then
If oDoc.Tables.Count > 0 Then
k = 0
bFound = True
For i = 1 To oDoc.Tables.Count
Set oTable = oDoc.Tables(i).Range
oTable.Copy
Set oRng = oNewDoc.Range
oRng.Collapse 0
oRng.InsertParagraphAfter
Set oRng = oNewDoc.Range
oRng.Collapse 0
oRng.Paste
k = k + 1
DoEvents
Next i
If bFound = True Then
oColl.Add strFileName & vbTab & k & " tables copied"
End If
End If
DoEvents
End If
oDoc.Close SaveChanges:=wdDoNotSaveChanges
strFileName = Dir$()
Wend
Set oLog = Documents.Add
For j = 1 To oColl.Count
oLog.Range.InsertAfter oColl(j) & vbCr
Next j
lbl_Exit:
Exit Sub
End Sub