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