☰

使用 VBA 将数据从多个 MS Word 文件复制到 Excel

tag-icon • tag-icon microsoft-word microsoft-office microsoft-excel-2007 vba
使用 VBA 将数据从多个 MS Word 文件复制到 Excel

我知道这个问题已经被问过了（将多个 Word 文档中的数据复制到一个 Excel 表中）问题是我无法使用这个答案。

我对 VBA 还不熟悉，但我以为自己可以搞定它。但我错了。我尝试使用上述线程中提供的代码来解析一些 Word 文档，一开始做了一些修改，然后就直接使用原始代码。不幸的是，我得到了“需要对象”的运行时错误。

代码如下。我尝试从中获取数据的文档是 Word 2003 文件（我首先尝试将“docx”更改为“doc”，然后将文档保存为 docx 并使用原始脚本，但没有帮助）。有一件事是它们实际上是扫描和 OCR 的纸质文档，所以...
A）里面的大多数表格都保存在框架中（不知道这是否会改变任何东西，考虑到它们的 xml 结构，应该不会）
b)当我尝试将它们保存为 docx 时，应用程序首先建议将它们保存为 rtfs。所以也许它们实际上是 rtf 文件，而不是 .doc？

Sub macro1()
  Dim xl As Object
 Set xl = CreateObject("excel.application")

 xl.Workbooks.Add
 xl.Visible = True

 'Here put your path where you have your documents to read:
 myPath = "C:\some\path\"  'End with '\'
 myFile = Dir(myPath & "*.docx")

 xlRow = 1
 Do While myFile <> ""
  Documents.Open Filename:=myPath & myFile, ConfirmConversions:=False, _
     ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
     PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
     WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""

  xlCol = 0
  For Each t In ActiveDocument.Tables
     For Each r In t.Rows
        For Each c In r.Range.Cells
           myText = c
           myText = Replace(myText, Chr(13), "")
           myText = Replace(myText, Chr(7), "")
           xlCol = xlCol + 1
           xl.ActiveWorkbook.ActiveSheet.Cells(xlRow, xlCol) = myText

        Next c
        xl.ActiveWorkbook.ActiveSheet.Cells(xlRow, xlCol + 1) = myFile
        xlRow = xlRow + 1
        xlCol = 0
     Next r
  Next t
  ActiveWindow.Close False

  myFile = Dir
  Loop

 xl.Visible = True
 End Sub

答案1

我已经测试过了。它确实运行良好。使用当前版本的代码之前，请注意以下几点：

  1. 应该添加到单词VBA，而不是 Excel 或其他（这可能是您收到“需要对象”错误的原因）。
  2. 它只处理 .docx
  3. 它处理所有实际的 MS Word 表格，而不是看起来像表格的图片。

我稍微修改了代码，使其更易读一些，至少对于来自 Excel VBA 世界的我来说是这样。您应该始终使用Option Explicit！

Option Explicit

Sub Word_tables_from_many_docx_to_Excel()
Dim myPath As String, myFile As String, myText As String
Dim xlRow As Long, xlCol As Long
Dim t As Table
Dim r As Row
Dim c As Cell
Dim xl As Object
 Set xl = CreateObject("excel.application")

 xl.Workbooks.Add
 xl.Visible = True

 'Here put your path where you have your documents to read:
 myPath = "C:\Temp\"  'End with '\'
 myFile = Dir(myPath & "*.docx")

 xlRow = 1
 Do While myFile <> ""
 Documents.Open myPath & myFile

  For Each t In ActiveDocument.Tables
     For Each r In t.Rows
        xlCol = 1
        For Each c In r.Range.Cells
           myText = c.Range.Text
           myText = Replace(myText, Chr(13), "")
           myText = Replace(myText, Chr(7), "")
           xl.ActiveWorkbook.ActiveSheet.Cells(xlRow, xlCol) = myText
           xlCol = xlCol + 1
        Next c
        xl.ActiveWorkbook.ActiveSheet.Cells(xlRow, xlCol + 1) = myFile
        xlRow = xlRow + 1
     Next r
     xlRow = xlRow + 1
  Next t

  ActiveWindow.Close False

 myFile = Dir
 Loop

End Sub

相关内容