vba excel表格内容与word文档内的表格内容匹配后校正写入

需求场景：

word文档中有多个表格；

每个表格中的起始井号和终止井号的内容通过#拼接起来；

拼接内容与excel 里A列的值进行匹配；

匹配成功则将excel对应行的其他列内容写入word文档表格里和表头一致的区域。

看图片说明

点击可放大

直接上VBA代码：

Private Sub CommandButton1_Click()

    全局地址 = App
    If 全局地址 = False Then Exit Sub

    '建立一个字典对象
    Set pDicX = CreateObject("Scripting.Dictionary")

    '设定字典的键为sheet1表的行号，字典的值为（A+行号）单元格的内容
    For ii1 = 2 To Sheet1.Range("a1048576").End(-4162).Row
        a = Sheet1.Range("a" & ii1)
        pDicX.Item(CStr(a)) = ii1

    Next

    Dim ok As Boolean
    ok = False
    '清空sheet2表
    Sheet2.Range("a2:b65535") = ""
    
    Set myword = CreateObject("word.application")
    myword.Visible = False
    
    Set doc = myword.Documents.Open(全局地址)    '打开文件
    Dim st As String
    '遍历word文档中的所有表格
    For ii1 = 1 To doc.Tables.Count
        'word表格中的第二行第4、6列替换特殊字符并用#拼接起来
        a = VBA.Replace(doc.Tables(ii1).Cell(2, 4).Range.Text, "", "") & "#" & VBA.Replace(doc.Tables(ii1).Cell(2, 6).Range.Text, "", "")
        '替换换行符
        a = VBA.Replace(a, Chr(10), "")
        a = VBA.Replace(a, Chr(13), "")
        
        '设定word文档当前循环表格第一行第2列的内容为当前循环数
        doc.Tables(ii1).Cell(1, 2) = ii1
        'word文档当前循环表格第3行第2列的内容进行替换
        doc.Tables(ii1).Cell(3, 2) = VBA.Replace(doc.Tables(ii1).Cell(3, 2).Range.Text, "-", "/")
        
        '将a转为字符串，并提取字典键值
        zhi = pDicX.Item(CStr(a))
        
        '如果键值不为空
        If zhi <> "" Then
            '将Sheet表同一行 B C D 列单元格的值写入到word表格的相同行的不同单元格
            doc.Tables(ii1).Cell(4, 2) = Sheet1.Range("b" & zhi)
            doc.Tables(ii1).Cell(4, 4) = Sheet1.Range("c" & zhi)
            doc.Tables(ii1).Cell(4, 6) = Sheet1.Range("d" & zhi) & "mm"
            
            '下面是不同情况的对应处理，需要根据具体业务来理解
            If Val(Sheet1.Range("e" & zhi)) = 0 Then
                doc.Tables(ii1).Cell(3, 4) = "/"
            Else

                doc.Tables(ii1).Cell(3, 4) = Sheet1.Range("e" & zhi) & "m"
            End If
            If Val(Sheet1.Range("f" & zhi)) = 0 Then
                doc.Tables(ii1).Cell(3, 6) = "/"
            Else
                doc.Tables(ii1).Cell(3, 6) = Sheet1.Range("f" & zhi) & "m"
            End If
            doc.Tables(ii1).Cell(5, 4) = Sheet1.Range("g" & zhi) & "m"
            doc.Tables(ii1).Cell(5, 6) = Sheet1.Range("h" & zhi) & "m"

            doc.Tables(ii1).Cell(6, 2) = Sheet1.Range("i" & zhi)
            doc.Tables(ii1).Cell(1, 4) = Sheet1.Range("j" & zhi)
        Else
            HL = Sheet2.Range("b65535").End(-4162).Row
            Sheet2.Range("a" & HL + 1) = "段号未找到"
            Sheet2.Range("b" & HL + 1) = a
            ok = True
        End If


    Next

    If ok = True Then
        Sheet2.Activate
        MsgBox "出现错误请检查"

    End If
    myword.Visible = True
End Sub

测试的两个文档（包含完整VBA)下载

链接:

https://pan.baidu.com/s/1j7xKTJqL_dktBX9Q33NwzQ