Код VBA, который копирует таблицы из нескольких файлов Word на отдельные листы в Excel Excel, называя этот лист именем документа Word?

Question

Я успешно использовал приведенный ниже макрос VBA, чтобы поместить несколько таблиц из нескольких документов Word в один лист в Excel, но я хочу, чтобы несколько таблиц из каждого документа Word перешли в разные листы с листами, названными по имени Word док. Любая помощь в разработке этого будет принята с благодарностью.

Sub ImportWordTable()

    Dim WordApp As Object
    Dim WordDoc As Object
    Dim arrFileList As Variant, FileName As Variant
    Dim tableNo As Integer                            'table number in Word

    Dim tableStart As Integer
    Dim tableTot As Integer
    Dim Target As Range

    'On Error Resume Next

    arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
                                              "Browse for file containing table to be imported", , True)

    If Not IsArray(arrFileList) Then Exit Sub         '(user cancelled import file browser)

    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = True

    Range("A:AZ").ClearContents
    Set Target = Range("A1")

    For Each FileName In arrFileList
        Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)

        With WordDoc
            tableNo = WordDoc.tables.Count
            tableTot = WordDoc.tables.Count
            If tableNo = 0 Then
                MsgBox WordDoc.Name & " contains no tables", vbExclamation, "Import Word Table"

            ElseIf tableNo > 1 Then
                tableNo = InputBox(WordDoc.Name & " contains " & tableNo & " tables." & vbCrLf & _
                                   "Enter the table to start from", "Import Word Table", "1")
            End If

            For tableStart = 1 To tableTot
                With .tables(tableStart)
                    .Range.Copy
                    'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
                    Target.Activate
                    ActiveSheet.Paste

                    Set Target = Target.Offset(.Rows.Count + 2, 0)
                End With
            Next tableStart

            .Close False
        End With

    Next FileName

    WordApp.Quit

    Set WordDoc = Nothing
    Set WordApp = Nothing
End Sub

Answer 1

Попробуйте следующий макрос. Позволяет выбрать исходную папку. Он создает новый рабочий лист для каждого документа и выводит все таблицы из этого документа одну под другой, с пустой строкой между ними. За исключением переноса текста, форматирование таблицы сохраняется в максимально возможной степени.

Sub GetTableData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, wdTbl As Word.Table
Dim strFolder As String, strFile As String, WkBk As Workbook, WkSht As Worksheet, r As Long
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Set WkBk = ActiveWorkbook
'Disable any Word Alerts
wdApp.DisplayAlerts =wdAlertsNone
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
  Set WkSht = WkBk.Sheets.Add
  WkSht.Name = Split(strFile, ".doc")(0)
  With wdDoc
    For Each wdTbl In .Tables
      With wdTbl.Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "[^13^l]"
        .Replacement.Text = "¶"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
      End With
      r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
      If r > 1 Then r = r + 2
      wdTbl.Range.Copy
      WkSht.Paste Destination:=WkSht.Range("A" & r)
    Next
    WkSht.UsedRange.Replace What:="¶", Replacement:=Chr(10), LookAt:=xlPart, SearchOrder:=xlByRows
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing: Set WkBk = Nothing
Application.ScreenUpdating = True
End Sub

Function GetFolder() As String
    Dim oFolder As Object
    GetFolder = ""
    Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
    If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
    Set oFolder = Nothing
End Function

Answer 2

Что-то вроде следующего, возможно. Поскольку я не могу воспроизвести ваши документы, моя тестовая среда не была идентичной ...

Следующий код объявляет объект Word.Table и Excel.Worksheet в списке объявленных переменных.

Объекту «Рабочий лист» присваивается значение ActiveSheet и позднее для каждого добавленного рабочего листа. Использование объекта вместо выделения или «активного» чего-либо почти всегда предпочтительнее - тогда для человека и VBA понятнее, что имеется в виду. ws также используется для более точного определения спецификаций Range.

Перед зацикливанием таблиц для рабочего листа Name устанавливается значение, сохраненное в Filename для документа Word.

Объект Table установлен на таблицу WordDoc.tables(tableStart). Более эффективно работать с объектом, а не каждый раз запрашивать полный «путь» к объекту. Это также легче читать.

Перед переходом к следующему документу Word добавляется новый лист.

Sub ImportWordTable()

    Dim WordApp As Object
    Dim WordDoc As Object
    Dim tbl As Object
    Dim arrFileList As Variant, FileName As Variant
    Dim tableNo As Integer                            'table number in Word

    Dim tableStart As Integer
    Dim tableTot As Integer
    Dim ws As Worksheet
    Dim Target As Range

    'On Error Resume Next

    arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
                                              "Browse for file containing table to be imported", , True)

    If Not IsArray(arrFileList) Then Exit Sub         '(user cancelled import file browser)

    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = True

    Set ws = ActiveSheet
    ws.Range("A:AZ").ClearContents

    For Each FileName In arrFileList
        Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
        With WordDoc
            tableNo = WordDoc.tables.Count
            tableTot = WordDoc.tables.Count
            If tableNo = 0 Then
                MsgBox WordDoc.Name & " contains no tables", vbExclamation, "Import Word Table"

            ElseIf tableNo > 1 Then
                tableNo = InputBox(WordDoc.Name & " contains " & tableNo & " tables." & vbCrLf & _
                                   "Enter the table to start from", "Import Word Table", "1")
            End If

            ws.Name = FileName
            For tableStart = 1 To tableTot
                Set Target = ws.Range("A1")
                Set tbl = .tables(tableStart)
                With tbl
                    .Range.Copy
                    'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False
                    Target.Activate
                    ws.Paste

                    Set Target = Target.Offset(.Rows.Count + 2, 0)
                End With
            Next tableStart

            .Close False
        End With
        Set ws = ws.Parent.Worksheets.Add

    Next FileName
    ws.Delete 'the last sheet is one too many
    WordApp.Quit

    Set WordDoc = Nothing
    Set WordApp = Nothing
End Sub