Извлечение таблиц из нескольких файлов в Excel с использованием VBA

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 не обновляется должным образом, когда я получаю сообщение: «это имя листа уже существует». Может быть, мне здесь не хватает некоторой логики VBA в отношении циклов и индексации.

Answer 1

Вы можете использовать Power Query для извлечения табличных данных из каждого документа Word в папке. Здесь отличный пример: http://www.excelandpowerbi.com/?p=201

Answer 2

Согласно 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

UDF CopyTableFromWordDoc не проверен, так как у меня не было текстового документа, чтобы проверить его на

Если вы затем запустите LookForWordDocs , он будет проходить через все файлы в указанной папке и передавать их в CopyTableFromWordDoc UDF (исключая любые не Word документы и любые временные Word документы). CopyTableFromWordDoc добавляет новый лист в текущую книгу и переименовывает лист так же, как имя файла. Затем он копирует таблицу (3) из текстового документа на этот новый лист

Подсказка: Вы можете добавить код для удаления любых существующих листов перед их добавлением в рабочую книгу; это защитит вас от попытки присвоить рабочему листу имя, совпадающее с именем существующего рабочего листа

Answer 3

Я согласен с другими ответами, что это будет лучше всего сделать в Excel VBA. Я бы предложил что-то вроде filelist = application.getopenfilename с множественным выбором, установленным в true, чтобы получить список файлов

Затем выполните цикл по списку, используя структуру i = 0 to len (filelist), если вы начинаете с 1 листа, каждый лист будет назван листом i + 1, который вы можете использовать для ссылки на него и добавления содержимого / переименования его et.c и вы можете вытащить имя файла из позиции списка.