проблема с копированием номера раздела и заголовка, где находится таблица - PullRequest
Новая
       20

проблема с копированием номера раздела и заголовка, где находится таблица

0 голосов
/ 28 мая 2019

Я пишу макрос Excel для извлечения данных из документов Word, представленных в определенной папке.

Я повторно использовал макрос, который отлично работает на документе Word, и он предоставит все подробности оновый лист Excel.

В текстовом документе данные представлены в таблицах с двумя столбцами (первый - это шаблон, а второй - описание).

Количество строк в таблицене везде одинаковы.Таблица присутствует в подзаголовке 3.

Например: Описание таблицы

image 1

Вместе с данными из таблицы, которую я хочускопировать заголовок и номер раздела (типа Заголовок 3).

Но с помощью приведенного ниже кода я могу правильно извлечь данные из таблиц.Но это копирование последнего экземпляра заголовка и номера раздела.Например: для Pattern_1, Pattern_2, Pattern_3 копируется имя раздела как 3.2.2 и заголовок как Usecase2 

Public Sub exportTableData()
    Dim t
    Dim r

    Dim ID As String
    Dim prefix As String

    Dim xR As Integer
    Dim xROld As Integer
    Dim chapter As String
    Dim useCase As String
    Dim text1 As String
    Dim text2 As String

    Dim docPath As String
    Dim docList As String
    Dim Workbook As Object
    Dim wordApp As Object
    Dim docObj As Object

    MsgBox "Please close all the Microsoft Word Applications"

    Do
        On Error Resume Next
        Set wordApp = GetObject(, "Word.Application")
        If Not wordApp Is Nothing Then
            wordApp.Quit
            Set wordApp = Nothing
        End If
    Loop Until wordApp Is Nothing

    ' track Excel worksheet row number
    xR = 2

    docPath = "folder which contains the DOcuments"
    ' get the list of all documents in the folder
    docList = Dir(docPath & "\*.doc", vbNormal)

    ThisWorkbook.Sheets("TableData").Activate

    While docList <> ""
        Set wordApp = CreateObject("Word.Application")
        wordApp.Visible = False
        Set docObj = wordApp.Documents.Open(Filename:=SRS_Path & "\" & docList, AddToRecentFiles:=False, Visible:=False)

        prefix = "Pattern"
    With wordApp.ActiveDocument
            ' Setup search to find usecase and corresponding section number
            wordApp.Selection.WholeStory
            wordApp.Selection.Find.ClearFormatting
            wordApp.Selection.Find.Style = "Heading 3"

            With wordApp.Selection.Find
                .Text = ""
                .Replacement.Text = ""
                .Forward = False
                .Wrap = wdFindContinue
                .Format = True
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
            End With

            wordApp.Selection.Find.Execute
    useCase = wordApp.Selection.Text
            ' Determine the string for chapter
            chapter = "Chapter " & wordApp.Selection.Range.ListFormat.ListString

      ' Loop through all tables in active Word document
            For Each t In srsDoc.Tables
                On Error Resume Next
                t.Range.Select
                ' xR tracks the current row in the Excel worksheet
                xROld = xR

                ' Loop through rows in the current table
                For Each r In t.Rows
                    text1 = r.Cells(1).Range.Text
                    ' Check if cell text start with prefix
                    If InStr(text1, prefix) = 1 Then
                        ' Check if row is not empty
                        If Not (r Is Nothing) Then
                            text2 = r.Cells(2).Range.Text
                            ThisWorkbook.ActiveSheet.Cells(xR, 1) = xR - 1
                            ThisWorkbook.ActiveSheet.Cells(xR, 2) = chapter
                            ThisWorkbook.ActiveSheet.Cells(xR, 3) = useCase
                            ThisWorkbook.ActiveSheet.Cells(xR, 4) = text1
                            ThisWorkbook.ActiveSheet.Cells(xR, 5) = Left(text2, Len(text2) - 2)
                            xR = xR + 1
                        End If
                    End If
                Next r
            Next t
    End With
        ' Clean up.
        docObj.Close
        wordApp.Quit
        Set wordApp = Nothing
        Set docObj = Nothing
    docList = Dir()
    Wend
    Workbook.ActiveSheet.Cells.EntireColumn.AutoFit
End Sub

Выход:

image 2

...