复制Word Table标题并将其粘贴到Excel中

Question

我有一个带有多个表的Word文档。 我在excel中有一些脚本，该脚本循环遍历word doc并提取word中的所有表并将其导入excel。 该脚本允许用户选择从哪个表开始（仅是fyi）。 我正在尝试做的是还让脚本带出该表的标题（在粗体和下划线中）并将其附加到相邻的列中。 并且还要将该列的标题命名为“ Section title”。 一些标题在标题之后是单词，然后是表格本身。 然后有些仅具有标题，然后紧随其后的表。 我需要的是带下划线的加粗标题。

这是单词document的样子：

这是我需要的：

这是我目前拥有的：

Option Explicit

Sub Macro1()

Dim wdDoc As Object
Dim wdFileName As Variant
Dim tableNo As Integer 'table number in Word
Dim resultRow As Long
Dim tableStart As Integer
Dim tableTot As Integer
Dim wdApp As Object, wdTable As Object
Dim iRow As Long, iCol As Long
Dim thisText As String, newText As String



On Error Resume Next

ActiveSheet.Range("A:AZ").ClearContents

wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table(s) to be imported")

If wdFileName = False Then Exit Sub '(user cancelled import file browser)

Set wdDoc = GetObject(wdFileName) 'open Word file

With wdDoc
    tableNo = wdDoc.Tables.Count
    tableTot = 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 the table to start from", "Import Word Table", "1")  'Enter table number to start at
    End If


    resultRow = 1

For tableStart = 1 To tableTot
With .Tables(tableStart)
    For iRow = 1 To .Rows.Count
        For iCol = 1 To .Columns.Count
            thisText = .Cell(iRow, iCol).Range.Text
            newText = Replace(thisText, Chr(13), vbCrLf)
            newText = Replace(newText, Chr(7), vbNullString)
            Cells(resultRow, iCol) = newText
        Next iCol
        resultRow = resultRow + 1
    Next iRow
    End With
    resultRow = resultRow + 1
Next tableStart
End With

End Sub

Answer 1

这篇文章的最佳答案可能是一个很好的起点。

给定您提供的内容，您可以搜索粗体和带下划线的文本，然后通过循环或您的首选项将选择的内容输入excel。

以下是链接中的代码（以节省时间），并进行了一些修改以与excel配合使用：

Sub SearchTitles()

    Dim wordDoc As Document
    Dim rng As Range
    Dim lastRow As Long
    Dim row As Integer

    Set wordDoc = Documents("your document filename")  ' open the doc prior to running
    Set rng = wordDoc.Range(0, 0)    

    With ThisWorkbook.Worksheets("your sheet name")
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).row
    End With

    For row = 1 To lastRow
        With rng.Find
            .ClearFormatting
            .Format = True
            .Font.Bold = True
            .Font.Underline = True
            While .Execute
                rng.Select
                rng.Collapse direction:=wdCollapseEnd

                ' Do something here with selection
               ThisWorkbook.Worksheets("your sheet name").Range("E" & row).Value = Selection

            Wend
        End With
        Set rng = Selection.Range
    Next   

End Sub

此解决方案非常幼稚，因为它假定您的文档中没有其他粗体和带下划线的文本，但希望它是一个开始的地方...祝您好运