我没有使用 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 循环似乎没有正确更新:“此工作表名称已存在”。也许我在这里缺少一些关于循环和索引的 VBA 逻辑。
最佳答案
根据 PEH 和我之前的评论,这是一种方法
在模块中复制以下 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 is untested as I didn't have a word document to test it against
如果然后运行 LookForWordDocs ,它将遍历指定文件夹中的所有文件并将它们传递到 CopyTableFromWordDoc UDF(不包括任何非
Word
文档和任何临时 Word
文档)。 CopyTableFromWordDoc 在当前工作簿中添加新工作表并将工作表重命名为与文件名相同。然后它将 table(3) 从 word 文档复制到这个新工作表提示:在将工作表添加到工作簿之前,您可以添加代码以删除任何现有工作表;这将防止您尝试使用与现有工作表相同的名称来命名工作表
关于vba - 使用 VBA 从多个文件中提取表格到 Excel,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/50151949/