vba - 将 Word 表格标题复制并粘贴到 Excel 中

问题描述

我有一个包含多个表格的 word 文档。我在 excel 中有一些脚本，它遍历 word doc 并提取 word 中的所有表格并将其带入 excel。该脚本允许用户选择从哪个表开始（仅供参考）。我想要做的还有让脚本带来该表的标题（它是粗体和下划线）并将其附加到相邻的列。并且还要将该列的标题命名为“部分标题”。一些标题在标题之后有单词，然后是表格本身。然后有些只有标题，然后是表格。我需要的是加粗下划线的标题。

这是word文档的样子：

这是我需要的：

这是我目前拥有的：

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

标签： vbaexcel

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

鉴于您提供的内容，您可以搜索粗体和带下划线的文本，并通过循环或您的偏好将选择输入到 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

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

vba - 将 Word 表格标题复制并粘贴到 Excel 中

问题描述

解决方案

推荐阅读