Question

我没有使用VBA的经验，因为我通常使用Matlab或有时使用Python，但似乎它是我所拥有的项目最有用的工具。基本上从大量的Word文件中，我必须提取一个表并将其放入一个Excel文件中。在YT教程中，我已经有了以下基本代码：

Sub CopyTable()
Application.Templates.LoadBuildingBlocks
Dim xlApp As Excel.Application
Dim xlwb As Excel.Workbook

Dim doc As Document
Dim tbl As Table
Dim LastRow As Long, LastColumn As Integer
Dim tblRange As Range

Set doc = ThisDocument

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlwb = xlApp.Workbooks.Add

Set tbl = doc.Tables(3)
With tbl
LastRow = .Rows.Count
LastColumn = .Columns.Count

Set tblRange = .Cell(1, 1).Range
tblRange.End = .Cell(LastRow, LastColumn).Range.End

tblRange.Copy

xlwb.Worksheets(1).Paste

End With

Set xlwb = Nothing
Set xlApp = Nothing

Set tblRange = Nothing
Set tbl = Nothing
Set doc = Nothing

End Sub

但是，我现在要做的是将此代码应用于具有多个doc（x）文件的特定文件夹。我想将每个单独的Word文件的表放在同一个Excel文件中的单独表中。如何使xlwb.Worksheets(1).Paste动态化？是否可以首先将Word文件的文件名粘贴到第一个单元格的Excel工作表中，然后复制它旁边的表格？

任何有关合并这些版本的指南都将受到高度赞赏。

增加：

使用下面的建议我已开始在Excel中编写脚本代码：

Sub ImportWordTable()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer
Dim iRow As Long
Dim iCol As Integer

filelist = Application.GetOpenFilename("Word files (*.doc),*.doc", , _
"Browse for file containing table to be imported", MultiSelect:=True)

If IsArray(filelist) Then

For i = 1 To Len(filelist)
wdFileName = filelist(i)
Set wdDoc = GetObject(wdFileName)

With wdDoc
TableNo = wdDoc.Tables.Count
If TableNo = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
ElseIf TableNo > 1 Then
TableNo = InputBox("This Word document contains " & TableNo & " tables." & vbCrLf & _
"Enter table number of table to import", "Import Word Table", "1")
End If
With .Tables(TableNo)
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
'ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
'ActiveWorkbook.Sheets(Worksheets.Count).Name = Dir(wdFileName)
'Worksheets(Dir(wdFileName)).Activate
ActiveWorkbook.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = Dir(wdFileName)
Worksheets(Dir(wdFileName)).Activate
ActiveSheet.Cells(iRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
Next iCol
Next iRow
End With
End With
wdDoc.Quit savechanges = False
Next i
Else
wdFileName = filelist
Set wdDoc = GetObject(wdFileName)
With wdDoc
TableNo = wdDoc.Tables.Count
If TableNo = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
ElseIf TableNo > 1 Then
TableNo = InputBox("This Word document contains " & TableNo & " tables." & vbCrLf & _
"Enter table number of table to import", "Import Word Table", "1")
End If
With .Tables(TableNo)
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
Cells(iRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
Next iCol
Next iRow
End With
End With
End If


Set wdDoc = Nothing

End Sub

我现在可以选择多个文件，并且还添加了一个用文件名命名工作表的函数。但是，从第一个文件复制信息后，代码无法正常运行。似乎for循环没有正确更新，因为我收到一条消息：＆＃34;此工作表名称已经存在＆＃34;。也许我在这里错过了关于循环和索引的一些VBA逻辑。

Answer 1

根据PEH＆s和我之前的评论，这是一个方法

将以下UDF复制到模块中：

Sub LookForWordDocs()
    Dim sFoldPath As String: sFoldPath = "c:\temp\"     ' Change the path. Ensure that your have "\" at the end of your path
    Dim oFSO As New FileSystemObject                    ' Requires "Microsoft Scripting Runtime" reference
    Dim oFile As file

    ' Loop to go through all files in specified folder
    For Each oFile In oFSO.GetFolder(sFoldPath).Files

        ' Check if file is a word document. (Also added a check to ensure that we don't pick up a temp Word file)
        If (InStr(1, LCase(oFSO.GetExtensionName(oFile.Path)), "doc", vbTextCompare) > 0) And _
                (InStr(1, oFile.Name, "~$") = 0) Then

            ' Call the UDF to copy from word document
            CopyTableFromWordDoc oFile

        End If

    Next

End Sub

以上UDF检查指定文件夹中的所有文件，并将Word文档传递给下面的UDF：

Sub CopyTableFromWordDoc(ByVal oFile As file)
    Dim oWdApp As New Word.Application                      ' Requires "Microsoft Word .. Object Library" reference
    Dim oWdDoc As Word.Document
    Dim oWdTable As Word.Table
    Dim oWS As Worksheet
    Dim lLastRow$, lLastColumn$

    ' Code to copy table from word document to this workbook in a new worksheet
    With ThisWorkbook

        ' Add the worksheet and change the name to what file name is
        Set oWS = .Worksheets.Add
        oWS.Name = oFile.Name

        ' Open Word document
        Set oWdDoc = oWdApp.Documents.Open(oFile.Path)

        ' Set table to table 3 in the document
        Set oWdTable = oWdDoc.Tables(1)

        ' Copy the table to new worksheet
        oWdTable.Range.Copy
        oWS.Range("A1").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone

        ' Close the Word document
        oWdDoc.Close False

        ' Close word app
        oWdApp.Quit

    End With

End Sub

CopyTableFromWordDoc UDF未经测试，因为我没有单词文档来对其进行测试

如果您运行 LookForWordDocs ，它将遍历指定文件夹中的所有文件并将其传递到 CopyTableFromWordDoc UDF（不包括任何非Word文档和任何文件临时Word文件）。 CopyTableFromWordDoc 在当前工作簿中添加新工作表，并将工作表重命名为与文件名相同。然后它将表格（3）从word文档复制到这个新的表格

提示：您可以添加代码以在将工作表添加到工作簿之前删除任何现有工作表;这样可以防止您尝试使用与现有工作表相同的名称命名工作表

Answer 2

您可以使用Power Query从文件夹中的每个Word文档中提取表格数据。这里有一个很好的例子：http://www.excelandpowerbi.com/?p=201

Answer 3

我同意其他答案，这在excel vba中最好。我建议像 filelist = application.getopenfilename，其中multiselect设置为true，以获取文件列表

然后使用for i = 0到len（filelist）结构循环遍历列表如果从1个工作表开始，每个工作表将命名为sheet i + 1，您可以使用它来引用它并添加内容/重命名它et.c你可以从列表位置拉出文件名。

使用VBA将多个文件中的表提取到Excel

3 个答案: