Копирование данных таблицы из Word в Excel

Прошли годы с тех пор, как я занимался VB, и мне трудно понять, почему я не записываю правильный контент.

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

У меня есть стиль заголовка 1, за которым следуют абзацы и таблицы.

Для каждого найденного стиля заголовка 1 я хочу скопировать текст заголовка 1, а также все таблицы со словом «Требование». Текст заголовка 1 должен находиться в первом столбце каждой строки таблицы.

Текущие проблемы, с которыми я столкнулся:

• Хотя Word показывает, что текст представляет собой «Заголовок 1», что бы я ни пытался, мне не удается получить текст для этого элемента.
• Поскольку я использую автоматически созданную форматированную нумерацию в Word, ни один текст/содержимое ячейки не попадает.
• Каждая ячейка, выводимая в Excel, имеет что-то вроде vbCrLf, которое отображается в Excel как специальный символ, похожий на высокий прямоугольник.

Я включил несколько скриншотов для справки.

Слово

Эксель

Sub CopyAllRequirementTablesToExcel()
    Dim tbl As Table
    Dim cell As cell
    Dim found As Boolean
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim i As Integer
    Dim j As Integer
    Dim row As Integer
    Dim hasVerticallyMergedCells As Boolean
    Dim startRow As Integer
    Dim endRow As Integer
    Dim headingText As String
    Dim rng As Range
    Dim para As Paragraph
    Dim foundHeading1 As Boolean
    Dim paraIndex As Integer
    
    ' Create a new instance of Excel if not already running
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    
    ' Reference the first workbook and sheet
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Sheets(1)
    
    ' Initialize the row to start pasting in Excel
    row = 1
    
    ' Loop through each table in the Word document
    For Each tbl In ActiveDocument.Tables
        found = False
        hasVerticallyMergedCells = False
        foundHeading1 = False
        
        ' Set the index of the paragraph containing the table
        paraIndex = tbl.Range.Paragraphs.Count
        
        ' Loop backward through paragraphs until we find the first instance of the next Heading 1 style
        Do Until foundHeading1 Or paraIndex = 1
            If tbl.Range.Paragraphs(paraIndex).Style = "Heading 1" Then
                headingText = Trim(tbl.Range.Paragraphs(paraIndex).Range.Text)
                foundHeading1 = True
            Else
                paraIndex = paraIndex - 1
            End If
        Loop
        
        ' If a Heading 1 style is not found, set headingText to an empty string
        If Not foundHeading1 Then
            headingText = "No Heading 1 found"
        End If
        
        ' Debugging: Print out the Heading 1 text
        Debug.Print "Heading 1 Text: " & headingText
        
        ' Check if any cell in the table contains "Requirement"
        For Each cell In tbl.Range.Cells
            If InStr(1, cell.Range.Text, "Requirement", vbTextCompare) > 0 Then
                found = True
                Exit For
            End If
        Next cell
        
        ' If "Requirement" is found in the table, check for vertically merged cells
        If found Then
            If tbl.Columns.Count > 1 Then ' Check if the table has more than one column
                For i = 2 To tbl.Rows.Count ' Skip the first row
                    For j = 1 To tbl.Columns.Count
                        startRow = tbl.cell(i, j).Range.Information(wdStartOfRangeRowNumber)
                        endRow = tbl.cell(i, j).Range.Information(wdEndOfRangeRowNumber)
                        If startRow <> endRow Then
                            hasVerticallyMergedCells = True
                            Exit For
                        End If
                    Next j
                    If hasVerticallyMergedCells Then Exit For
                Next i
            End If
            
            ' Skip the table if it has vertically merged cells
            If Not hasVerticallyMergedCells Then
                ' Insert the heading text as the first column
                xlSheet.Cells(row, 1).Value = headingText
                
                ' Copy the table to Excel, starting from the second column and second row
                For i = 2 To tbl.Rows.Count ' Skip the first row
                    For j = 1 To tbl.Columns.Count
                        ' Set the value of the cell in Excel to the formatted text of the cell in Word
                        xlSheet.Cells(row + i - 2, j).Value = Trim(tbl.cell(i, j).Range.Text)
                    Next j
                Next i
                
                ' Update the row to the next empty row
                row = row + tbl.Rows.Count - 1 ' Subtract 1 to remove the empty row between tables
            End If
        End If
    Next tbl
    
    ' Make Excel visible
    xlApp.Visible = True
    
    ' Clean up
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
    ' Notify if no table with 'Requirement' heading is found
    'If Not found Then
        'MsgBox "No table with 'Requirement' heading found.", vbInformation
    'End If
End Sub 

Обновление от 23 мая 24 г. Спасибо всем за ваши предложения, я начал все сначала и стал намного ближе.

Я преобразовал значения в ASCII и обнаружил, что на самом деле это Chr(13), поэтому я наконец исправил нечетные символы, заменив их на vbCrLf, и это работает. Еще мне пришлось удалить последний vbCr, а также установить WrapText = True.

Проблема, с которой я сейчас сталкиваюсь, заключается в том, что Range.Text игнорирует автоматически сгенерированные числовые значения Word. Итак, если у меня есть список 1.1.1, 1.1.2, 1.1.3, он просто ничего не копирует.

В приведенном ниже коде я добавил «Если y = 2 Тогда» в надежде использовать Range.ListFormat.ListString для захвата форматированного значения, но оно все равно отображается пустым.

Я также считаю, что, возможно, я неправильно увеличиваю строки/столбцы.

Незначительные изменения в Word для исправления многострочного отображения: https://i.imgur.com/n53svUI.png Обновленный вывод Excel: https://i.imgur.com/oI7aA4U.png Я попытался загрузить/вставить файл docm, но при вставке URL-адреса возникла ошибка. (извините, новичок здесь)

            Option Explicit
        Sub CopySDDFromWordToExcel()
            Dim oTab As Table, colHead As New Collection, sHead As String
            Dim i As Long, r As Range
            Dim row As Integer
            Dim column As Integer
            Dim x As Integer
            Dim y As Integer
            Dim xlApp As Object
            Dim xlBook As Object
            Dim xlSheet As Object

            ' Create a new instance of Excel if not already running
            On Error Resume Next
            Set xlApp = GetObject(, "Excel.Application")
            If Err.Number <> 0 Then
                Set xlApp = CreateObject("Excel.Application")
            End If
            On Error GoTo 0
            
            row = 1
            column = 1
            
            ' Reference the first workbook and sheet
            xlApp.Visible = True
            Set xlBook = xlApp.Workbooks.Add
            Set xlSheet = xlBook.Sheets(1)
            
            Set r = ActiveDocument.Content
            ' Use Find instead of looping through all paragraphs to find all Heading 1 instances
            With r.Find
                .ClearFormatting
                .Style = wdStyleHeading1
                .Forward = True
                .Wrap = wdFindStop
                Do While .Execute
                    colHead.Add .Parent.Duplicate
                    r.Collapse Direction:=wdCollapseEnd
                Loop
            End With
            If colHead.Count = 0 Then
                MsgBox "Can't find Heading 1"
                Exit Sub
            End If
            For i = 1 To colHead.Count
                sHead = colHead(i).text
                If i = colHead.Count Then
                    colHead(i).End = ThisDocument.Range.End
                Else
                    colHead(i).End = colHead(i + 1).Start - 1
                End If
                If colHead(i).Tables.Count > 0 Then
                    Debug.Print "-----"
                    Debug.Print sHead
                    Debug.Print "-- Table: ", i, "---"
                    
                    For Each oTab In colHead(i).Tables
                        With oTab.Range.Find
                            .ClearFormatting
                            .text = "Requirement"
                            If .Execute Then
                                Debug.Print "-----"
                                Debug.Print "Found table"
                                Debug.Print "Start: "; .Parent.Start
                                Debug.Print "End: "; .Parent.End
                                
                                ' Copy the table to Excel, starting from the second column and second row
                                For x = 2 To oTab.Rows.Count ' Loop through all rows, skipping the 1st row
                                    'xlSheet.Cells(row, 1).Value = sHead ' Insert heading text as the first column
                                        For y = 1 To oTab.Columns.Count ' Loop through all columns
                                            ' Insert heading text as the first column
                                            If y = 1 Then
                                                xlSheet.Cells(row + x - 2, y).Value = sHead ' Insert heading text as the first column
                                            End If
                                            ' Insert requirements # ID as the second column
                                            If y = 2 Then
                                                xlSheet.Cells(row + x - 2, y + 1).Value = oTab.cell(x, y).Range.ListFormat.ListString
                                            End If
                                            ' Insert remaining cells
                                            If y > 2 Then
                                                xlSheet.Cells(row + x - 2, y + 1).Value = Replace(RemoveLastCarriageReturn(Trim(oTab.cell(x, y).Range.text)), Chr(13), vbCrLf)
                                                xlSheet.Cells(row + x - 2, y + 1).WrapText = True
                                            End If
                                            
                                            'xlSheet.Cells(row + x - 2, y + 1).WrapText = True
                                            'ConverToASCII (xlSheet.Cells(row + x - 2, y + 1).Value)
                                        Next y
                                        row = row + 1
                                Next x
                                
                                ' Increment row counter
                                'row = row + 1 ' Increment by the number of rows in the table plus one for the next row
                                ' column = column + oTab.Columns.Count + 1
                            End If
                        End With
                    Next
                End If
            Next

            ' Make Excel visible
            xlApp.Visible = True
            
            ' Clean up
            Set xlSheet = Nothing
            Set xlBook = Nothing
            Set xlApp = Nothing

        End Sub

        Function RemoveLastCarriageReturn(ByVal inputString As String) As String
            Dim lastCRPosition As Integer
            lastCRPosition = InStrRev(inputString, vbCr)
            
            If lastCRPosition > 0 Then
                RemoveLastCarriageReturn = Left(inputString, lastCRPosition - 1)
            Else
                RemoveLastCarriageReturn = inputString
            End If
        End Function

        Function ConverToASCII(inputString As String) As String
            Dim asciiValues As String
            Dim i As Integer
            
            ' Initialize the string to store ASCII values
            asciiValues = ""
            
            ' Loop through each character in the input string
            For i = 1 To Len(inputString)
                ' Retrieve the ASCII value of the character and append it to the result string
                asciiValues = asciiValues & Asc(Mid(inputString, i, 1)) & " "
            Next i
            
            ' Return the string containing ASCII values
            ' ConverToASCII = asciiValues
            
            Debug.Print "The ASCII values of '" & inputString & "' are: " & asciiValues
        End Function