选取特定段落，并粘贴到特定文档的特定位置

国士无双yyx

想要将报告中每个“4 维修建议”标题下的三段内容对应粘贴到汇总表格中

duquancai

代码放于“2.2 主要缺损情况及维修内容与数量汇总表.docx”文档！
Dim d As Object
Sub main()
    Dim doc As Document, ph$, f$, tb As Table, n&, sr$
    ph = ThisDocument.Path: f = "相城区黄埭镇2017年 1~34(1).docx" '两个文档在同一个文件夹内！
    Set doc = Documents.Open(ph & "\" & f, Visible:=False)
    Call myData(doc)
    Set tb = ThisDocument.Tables(1): n = tb.Rows.Count
    For i = 2 To n
        sr = Split(tb.Cell(i, 1).Range.Text, Chr(13) & Chr(7))(0) & Left(tb.Cell(i, 2).Range.Text, 4)
        For j = 3 To 4
            With tb.Cell(i, j).Range
                .End = .End - 1: sr = sr & .Text
            End With
        Next
        If d.Exists(sr) Then
            With tb.Cell(i, 6).Range
                .Text = d(sr): .Start = .End - 1
                .MoveStartWhile vbCr, wdBackward: .Text = Empty
            End With
        End If
        sr = ""
    Next
End Sub
Function ar(P As Range, k As String)
    Dim Q As Range, n As Long, arr()
    Set Q = P.Duplicate
    With P.Find
        Do While .Execute(k, , , -1)
            If Not P.InRange(Q) Then Exit Do
            n = n + 1: ReDim Preserve arr(n)
            arr(n - 1) = P.Start
        Loop
    End With
    If n > 0 Then arr(n) = Q.End - 1: ar = arr
End Function
Sub myData(doc As Document)
    Dim Q As Range, sr$, tb As Table, s$
    brr = ar(doc.Content, "[0-9]@. *[A-Z][0-9]{1,}")
    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(brr)
        Set Q = doc.Range(brr(i - 1), brr(i)): s = ""
        sr = Replace(Replace(Q.Paragraphs(1).Range.Text, " ", ""), vbCr, "")
        sr = Replace(Replace(sr, "", ""), ".", "")
        With Q.Find
            If .Execute("维修建议*特殊检测建议", , , -1) Then
                If Q.Tables.Count > 0 Then
                    For Each tb In Q.Tables
                        tb.ConvertToText 0, True
                    Next
                End If
                For j = 2 To Q.Paragraphs.Count - 1
                    s = s & Q.Paragraphs(j).Range.Text
                Next
            End If
        End With
        d(sr) = s
    Next
    doc.Close 0
End Sub