注：vba偶并不太熟（偶一般是用c#和delphi的）,VBA只是稍有了解，以下代码大部分是偶google到的内容拼出来的。。。。。
如下，使用时先更改test下的docpath和xlspath路径设定，docpath即你的word的目录，此目录包括子目录下的所有doc将被读取，xlspath即输出目录，需要存在
在VBA窗口中，先在视图下显示立即窗口以观察进度，程序最后的输出类似这样
正在读取[1]:->D:\1\Resume.doc
正在生成:->d:\2\Resume
正在读取[2]:->D:\1\简历(简).doc
正在生成:->d:\2\简历(简)
正在读取[3]:->D:\1\计数器说明.doc
正在生成:->d:\2\计数器说明
共耗时0分41秒
Option Explicit
Dim docpath As String, xlspath As String
'ResultFlag=0 获取路径
'ResultFlag=1 获取文件名
'ResultFlag=2 获取扩展名
Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String
Dim SplitPos As Integer, DotPos As Integer
SplitPos = InStrRev(FullPath, "\")
DotPos = InStrRev(FullPath, ".")
Select Case ResultFlag
Case 0
SplitPath = Left(FullPath, SplitPos - 1)
Case 1
If DotPos = 0 Then DotPos = Len(FullPath) + 1
SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1)
Case 2
If DotPos = 0 Then DotPos = Len(FullPath)
SplitPath = Mid(FullPath, DotPos + 1)
Case Else
Err.Raise vbObjectError + 1, "SplitPath Function", "Invalid Parameter!"
End Select
End Function
Public Function FileFolderExists(ByVal strFullPath As String) As Boolean
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0
End Function
Sub Test() '使用双字典，旨在提高速度
Dim MyName, Dic, Did, I, T, F, TT, MyFileName, Doc, Ke
Dim count As Integer
count = 0
T = Time
docpath = "D:\1\"
xlspath = "d:\2\"
Set Dic = CreateObject("Scripting.Dictionary") '创建一个字典对象
Set Did = CreateObject("Scripting.Dictionary")
Dic.Add (docpath), ""
I = 0
Do While I < Dic.count
Ke = Dic.keys '开始遍历字典
MyName = Dir(Ke(I), vbDirectory) '查找目录
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录
Dic.Add (Ke(I) & MyName & "\"), "" '就往字典中添加这个次级目录名作为一个条目
End If
End If
MyName = Dir '继续遍历寻找
Loop
I = I + 1
Loop
'Did.Add ("文件清单"), "" '以查找D盘下所有EXCEL文件为例
For Each Ke In Dic.keys
MyFileName = Dir(Ke & "*.doc")
Do While MyFileName <> ""
Doc = Ke & MyFileName
Did.Add (Doc), ""
count = count + 1
Debug.Print "正在读取[" & count & "]:->" & Doc
doc2xls (Doc)
MyFileName = Dir
Loop
Next
' For Each Sh In ThisWorkbook.Worksheets
' If Sh.Name = "XLS文件清单" Then
' Sheets("XLS文件清单").Cells.Delete
' F = True
' Exit For
' Else
' F = False
' End If
' Next
'If Not F Then
' Sheets.Add.Name = "XLS文件清单"
'End If
'Sheets("XLS文件清单").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
TT = Time - T
Debug.Print "共耗时" & Minute(TT) & "分" & Second(TT) & "秒"
End Sub
Sub doc2xls(filename As String)
Dim xlApp As Object, xlSheet As Object, outfile As String, c As Object
Set xlApp = CreateObject("Excel.Application")
Set xlSheet = xlApp.Workbooks.Add.Sheets(1)
Dim Wapp As Object, Doc As Object, GetDocText As Object 'Word Application 对象、Document 对象
Set Wapp = CreateObject("Word.Application") '创建Word Application 对象
Set Doc = Wapp.Documents.Open(filename, ReadOnly:=True) '打开文档,返回一个文档对象
'xlSheet.Range("A1") = Doc.Content.Text
Doc.Application.Selection.WholeStory ''''全选
Doc.Application.Selection.Copy ''''''''''复制
xlSheet.Range("A1").Select
xlSheet.Paste
outfile = xlspath + Replace(SplitPath(filename, 1), ".doc", ".xls")
Debug.Print "正在生成:->" & outfile
xlSheet.Parent.SaveAs outfile
xlApp.Quit
Set xlSheet = Nothing
Set xlApp = Nothing
Wapp.Quit
Set Doc = Nothing
Set Wapp = Nothing
End Sub
温馨提示：答案为网友推荐，仅供参考