代碼如下：

Dim FilesList(1 To 99999, 1 To 1) '在主SUB代碼外定義數(shù)組及位置變量，為跨SUB調(diào)用

Dim FilesList_i As Integer

Dim FS As Object

Dim If_Sub As String

Sub 遍歷文件() '主SUB

Dim Path_todo As String

Path_todo = InputBox('輸入待處理目錄路徑', '路徑錄入', 'e:\test')                    '輸入目錄

If_Sub = InputBox('是否遍歷子文件夾【0→否；1→是】', '是否遍歷', 1) '是否遍歷的記錄

Set FS = CreateObject('Scripting.FileSystemObject')

Call GetAllFiles(Path_todo) 'Call 遍歷文件過程

If FilesList_i = 0 Then Exit Sub '若遍歷后發(fā)現(xiàn)沒有任何文件，就直接退出'

Call Tables_to_DOC 'Call 提取表格數(shù)據(jù)過程

End Sub

Sub GetAllFiles(ByVal RecepPath As String)'獲取全部文件sub

Dim Mainfolder, SubFolder, File_Currentfolder As Object '分別為當(dāng)前主目錄，子目錄，主目錄下文件列表

On Error Resume Next '一些系統(tǒng)文件夾可能導(dǎo)致代碼報(bào)錯(cuò)，可跳過

Set Mainfolder = FS.getfolder(RecepPath)

For Each File_Currentfolder In Mainfolder.Files '在當(dāng)前主目錄下所有Files中遍歷

FilesList_i = FilesList_i + 1 '存儲(chǔ)用數(shù)組中位置偏移

If Right(RecepPath, 1) <> '\' Then '避免出現(xiàn)格式不完整的目錄路徑

RecepPath = RecepPath & '\'

End If

FilesList(FilesList_i, 1) = RecepPath & File_Currentfolder.Name '用數(shù)組記錄文件路徑和完整文件名

Next

If Int(If_Sub) <> 1 Then Exit Sub '若不需要獲取子目錄中文件，就不需要遞歸'

For Each SubFolder In Mainfolder.SubFolders

Call GetAllFiles(SubFolder.Path) '遞歸調(diào)用

Next

End Sub

Sub Tables_to_DOC()'提取數(shù)據(jù)sub

Dim WordDOC, CurDOC As Object 'DOC文件對(duì)象

Dim TableCount, Table_i As Integer   '當(dāng)前DOC中表格個(gè)數(shù)，表格序數(shù)

Dim r, c, i, CellsR, CellsC As Integer '提取表格數(shù)據(jù)時(shí)需要的行號(hào)變量，列號(hào)變量，記錄用數(shù)組的位置變量，Excel中的行列序號(hào)

Set WordDOC = CreateObject('word.application')

CellsR = 1

CellsC = 1 '提取后的數(shù)據(jù)在Excel中從A1單元格開始記錄

For i = 1 To UBound(FilesList) - LBound(FilesList) + 1 '遍歷數(shù)組，只針對(duì)DOC和DOCX處理

If Right(UCase(FilesList(i, 1)), 4) = '.DOC' Or Right(UCase(FilesList(i, 1)), 4) = 'DOCX' Then '檢查擴(kuò)展名是否為Word文件

Set CurDOC = WordDOC.documents.Open(FilesList(i, 1))

WordDOC.Visible = False

TableCount = WordDOC.ActiveDocument.tables.Count '記錄當(dāng)前DOC中表格個(gè)數(shù)

For Table_i = 1 To TableCount

CellsC = 0 '每一張word表格在xls中的位置從第一列開始

For r = 1 To WordDOC.ActiveDocument.tables(Table_i).Rows.Count

CellsC = 0 '每一行也從xls的第一列開始存放

For c = 1 To WordDOC.ActiveDocument.tables(Table_i).Columns.Count

On Error Resume Next

CellsC = CellsC + 1

Cells(CellsR, CellsC).Value = WordDOC.ActiveDocument.tables(Table_i).Cell(r, c).Range.Text 'Word表格的內(nèi)容通過該方法獲取

Cells(CellsR, CellsC).Value = Left(Cells(CellsR, CellsC).Value, Len(Cells(CellsR, CellsC).Value) - 1) '去除獲取內(nèi)容末尾的黑點(diǎn)

Next c

CellsR = CellsR + 1

Next r

Next Table_i

CurDOC.Close '關(guān)閉已復(fù)制完表格的DOC

End If

Next i '尋找下一DOC文檔

End Sub