excle表格按照A列单位自动将相关表格及内容匹配计算到word模板

苏阳湖wzy

论坛的各位老师们：大家好！今天求助一个老问题，即：excle表格按照A列单位自动将相关表格及内容匹配计算到word模板，详情请见附件，谢谢！

3190496160

Sub 生成word文档()
Application.ScreenUpdating = False
Dim oFso
Set oFso = CreateObject("Scripting.FileSystemObject")
Dim i%, arr, myPath$, wdApp, wdD
Dim ar As Variant, cr As Variant
Dim br(), brr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
myPath = ThisWorkbook.Path & "\"
Set sh = ThisWorkbook.Worksheets(1)
With Sheets("Sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:g" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(Trim(ar(i, 1))) = ar(i, 2)
    End If
Next i
Set wdApp = CreateObject("word.application")
wdApp.Visible = False
For Each k In d.keys
    n = 0: je = 0
    ReDim br(1 To UBound(ar), 1 To 4)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) = k Then
            je = je + ar(i, 6)
            dw = ar(i, 2) & "(" & ar(i, 1) & ")"
            n = n + 1
            For j = 3 To 6
                br(n, j - 2) = ar(i, j)
            Next j
            If Trim(ar(i, 7)) <> "" Then bh = ar(i, 7)
        End If
    Next i
    rq = br(1, 1) & "至" & br(n, 1)
    sh.[l1] = je
    dje = sh.[j1]
    FileCopy myPath & "模板.doc", myPath & "文书\" & k & ".doc"
    Set wdD = wdApp.Documents.Open(myPath & "文书\" & k & ".doc")
    With wdApp
        .Selection.HomeKey Unit:=6 'wdStory '光标置于文件首
        If .Selection.Find.Execute("sj1") Then '查找到指定字符串
           .Selection.Text = bh '替换字符串
        End If
        .Selection.HomeKey Unit:=6 ''wdStory '光标置于文件首
        If .Selection.Find.Execute("sj2") Then '查找到指定字符串
           .Selection.Text = dw '替换字符串
        End If
        .Selection.HomeKey Unit:=6 'wdStory '光标置于文件首
        If .Selection.Find.Execute("sj3") Then '查找到指定字符串
           .Selection.Text = rq '替换字符串
        End If
        .Selection.HomeKey Unit:=6 'wdStory '光标置于文件首
        If .Selection.Find.Execute("sj4") Then '查找到指定字符串
           .Selection.Text = dje '替换字符串
        End If
        .Selection.HomeKey Unit:=6 'wdStory '光标置于文件首
        If .Selection.Find.Execute("sj5") Then '查找到指定字符串
           .Selection.Text = je '替换字符串
        End If
        
    End With
        wdD.Save
        wdD.Close True
    Next k
    wdApp.Quit
    Set wdD = Nothing
    Set wdApp = Nothing
Application.ScreenUpdating = False
MsgBox "ok!"
End Sub
Sub 按模板生成文档()
Application.ScreenUpdating = False
    Dim i%, arr, myPath$, wdApp, wdD
    Dim oFso
    Set oFso = CreateObject("Scripting.FileSystemObject")
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    myPath = ThisWorkbook.Path & "\"
    Set wdApp = CreateObject("word.application")
    wdApp.Visible = False
    arr = Sheets("sheet1").Range("A1:m" & Cells(Rows.Count, 1).End(xlUp).Row)
    For i = 3 To UBound(arr)
        If Trim(arr(i, 1)) = "" Then
            arr(i, 1) = arr(i - 1, 1)
            arr(i, 2) = arr(i - 1, 2)
            arr(i, 3) = arr(i - 1, 3)
        End If
        zf = Trim(arr(i, 1)) & "-" & Trim(arr(i, 3))
        d(zf) = ""
    Next i
    For Each k In d.keys
        n = 0: hz = ""
        ReDim brr(1 To UBound(arr), 1 To 4)
        For i = 3 To UBound(arr)
            If Trim(arr(i, 1)) & "-" & Trim(arr(i, 3)) = k Then
                zb = arr(i, 2)
                n = n + 1
                brr(n, 1) = arr(i, 6)
                brr(n, 2) = arr(i, 7)
                brr(n, 3) = arr(i, 9)
                brr(n, 4) = Mid(Trim(arr(i, 8)), 7, 8)
            End If
        Next i
        FileCopy myPath & "___村集体经济组织成员股权登记簿.docx", myPath & "生成的文件\" & "___村集体经济组织成员股权登记簿" & k & ".docx"
        Set wdD = wdApp.Documents.Open(myPath & "生成的文件\" & "___村集体经济组织成员股权登记簿" & k & ".docx")
        With wdD.Tables(1)
             .cell(2, 2).Range.Text = Split(k, "-")(0)
             .cell(2, 5).Range.Text = Split(k, "-")(1)
             .cell(2, 8).Range.Text = zb
             For i = 1 To n
                For j = 1 To 4
                   .cell(i + 4, j).Range.Text = brr(i, j)
                Next j
            Next i
        End With
        wdD.Save
        wdD.Close True
    Next k
    wdApp.Quit
    Set wdD = Nothing
    Set wdApp = Nothing
Application.ScreenUpdating = False
    MsgBox "ok!"
End Sub

3190496160

附件.rar (25.67 KB, 下载次数: 17)

2023-4-5 18:45 上传

点击文件名下载附件

3190496160

只写了生成表头的代码，具体明细的代码没有写，因为，不明白，如果实际数据的行数超过了你目前word中预留的行数该如何处理
不要删除文书文件夹，生成的文档就是在这个文件夹内，不要删除[J1]单元格的公式，否则没法生成大写金额

苏阳湖wzy

3190496160 发表于 2023-4-5 18:47
只写了生成表头的代码，具体明细的代码没有写，因为，不明白，如果实际数据的行数超过了你目前word中预留的 ...

附件仅仅是提供了3个单位的模拟数据，实际数据单位的数量不固定，且每个单位的行数也有多有少，所以word中每个单位的行数也是有变化的。

苏阳湖wzy

非常感谢春风化雨老师，但sj3生成的数据有错误，例如A单位应该是“2015/1/1至2022/1/31”，而不是“2015/1/1至2022/1/1”。另外，实际数据中每个单位的行数有多有少，表格的明细数据能不能生成呢？

苏阳湖wzy

3190496160 发表于 2023-4-5 18:47
只写了生成表头的代码，具体明细的代码没有写，因为，不明白，如果实际数据的行数超过了你目前word中预留的 ...

非常感谢春风化雨老师，但sj3生成的数据有错误，例如A单位应该是“2015/1/1至2022/1/31”，而不是“2015/1/1至2022/1/1”。另外，实际数据中每个单位的行数有多有少，表格的明细数据能不能生成呢？

苏阳湖wzy

rq = br(1, 1) & "至" & br(n, 2)
2015/1/1至2022/1/31

苏阳湖wzy

3190496160 发表于 2023-4-5 18:47
只写了生成表头的代码，具体明细的代码没有写，因为，不明白，如果实际数据的行数超过了你目前word中预留的 ...

非常感谢春风化雨老师，实际数据中每个单位的行数有多有少，表格的明细数据能不能生成呢？

3190496160

苏阳湖wzy 发表于 2023-4-5 19:48
非常感谢春风化雨老师，实际数据中每个单位的行数有多有少，表格的明细数据能不能生成呢？

肯定是可以的，但是，代码量太大，工作量不小，得有时间坐下来慢慢弄