EXCEL表格数据填写到WORD里

rendiule01

我的excel 采购明细表是2个sheet主表、子表

主表是一行数据 采购单的表头
子表是多行数据 采购单的商品采购明细
现在求助VBA大佬，把这些数据写入采购单word打印模版里，红色字 来自采购明细表的数据，
数据写入完成并转换成PDF，文件名为采购单号+当前时间
  谢谢！
打印套版.rar (35.17 KB, 下载次数: 20)

2024-5-27 10:14 上传

点击文件名下载附件

3190496160

word中的表格行数，是要根据excel中行数变化的吧？

3190496160

这部分中的一些项目在excel中根本找不到，不知道是固定的，还是什么？

rendiule01

3190496160 发表于 2024-5-27 14:31
这部分中的一些项目在excel中根本找不到，不知道是固定的，还是什么？

word商品的行数是根据excel子表的行数变化的
  甲方和乙方资料在sexcel主表里啊

rendiule01

3190496160 发表于 2024-5-27 14:31
这部分中的一些项目在excel中根本找不到，不知道是固定的，还是什么？

重新上传EXCEL 文件 采购明细表gai.rar (9.33 KB, 下载次数: 4)

2024-5-27 19:34 上传

点击文件名下载附件

gwjkkkkk

rendiule01 发表于 2024-5-27 19:34
重新上传EXCEL 文件

金额有不同币种，那大写有难度了？

rendiule01

gwjkkkkk 发表于 2024-5-27 20:07
金额有不同币种，那大写有难度了？

大写不用管它， 我EXCEL 里会设置好，到时直接取数据就好

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim wdApp As Word.Application, strFileName$, strPath$, vTemp1, vTemp
    Dim ar, br, cr, i&, j&, n&, k&, strSaveName$, dic As Object, vKey
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "采购模版.docx"
    If Dir(strFileName) = "" Then MsgBox "模板文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
    On Error Resume Next
   
    Set dic = CreateObject("Scripting.Dictionary")
    ar = Worksheets(2).[A1].CurrentRegion.Value

    For i = 2 To UBound(ar)
        dic(ar(i, 1)) = dic(ar(i, 1)) & " " & i
    Next i
   
    For Each vKey In dic.keys
        cr = Split(dic(vKey))
        ReDim br(1 To UBound(cr), 1 To UBound(ar, 2) - 1)
        For i = 1 To UBound(cr)
            For j = 1 To UBound(br, 2)
                br(i, j) = ar(cr(i), j + 1)
            Next j
        Next i
        dic(vKey) = br
    Next
   
    ar = Worksheets(1).[A1].CurrentRegion.Value
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
    End If
   
    For i = 2 To UBound(ar)
        With wdApp.documents.Open(strFileName)
            strSaveName = strPath & ar(i, 1)
            For j = 1 To UBound(ar, 2)
                With .Content.Find
                    .ClearFormatting
                    .Text = "数据" & Format(j, "000")
                    .Replacement.Text = ar(i, j)
                    .Execute Replace:=wdReplaceAll
                End With
            Next j
            If dic.Exists(ar(i, 1)) Then
                br = dic(ar(i, 1))
                With .Tables(1)
                    For j = 1 To UBound(br) + 1: .Rows.Add: Next
                    For k = 1 To UBound(br)
                        For j = 1 To UBound(br, 2)
                            .Cell(k + 1, j).Range.Text = br(k, j)
                        Next j
                    Next k
                    n = UBound(br) + 2
                    .Cell(n, 4).Merge .Cell(n, 4).Next
                    .Cell(n, 2).Range.Text = "合计"
                    .Cell(n, 3).Range.Text = WorksheetFunction.Sum(Application.Index(br, , 3))
                    .Cell(n, 4).Range.Text = "CNY" '
                    vTemp = WorksheetFunction.Sum(Application.Index(br, , 6))
                    vTemp1 = vTemp
                    .Cell(n, 5).Range.Text = vTemp
                    vTemp = digitToDx(CCur(vTemp))
                End With
                With .Content.Find
                    .ClearFormatting
                    .Text = "数据031"
                    .Execute
                    If .Found = True Then
                        .Parent.Text = "人民币" & vTemp & "（￥：" & vTemp1 & "元）"
                    End If
                End With
            End If
            .SaveAs strSaveName: .Close
        End With
    Next i
   
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

Function digitToDx(curNum As Currency) As String
    Dim toChi$, ar$(), frontChi$, behindChi$, j$, f$
   
    If Val(curNum) = 0 Then digitToDx = "": Exit Function
   
    toChi = WorksheetFunction.Text(Round(Val(curNum), 2) + 0.001, "[DBNUM2]")
    ar = Split(toChi, ".")
    frontChi = ar(0): behindChi = Left(ar(1), 2)
    j = Mid(behindChi, 1, 1)
    f = Mid(behindChi, 2, 1)
   
    If f = "零" Then
        If j = "零" Then digitToDx = frontChi & "元整"
        If j <> "零" Then digitToDx = frontChi & "元" & j & "角"
    Else
        If j = "零" Then digitToDx = frontChi & "元" & j & f & "分"
        If j <> "零" Then digitToDx = frontChi & "元" & j & "角" & f & "分"
    End If
   
End Function

gwjkkkkk

请参考。。。

rendiule01

gwjkkkkk 发表于 2024-5-28 22:11
Option Explicit
Sub TEST1()
    Dim wdApp As Word.Application, strFileName$, strPath$, vTemp1, v ...

谢谢老师
还有个小问题，若是付款方式是 隐藏行，








Sub TEST1()
    ' 声明变量
    Dim wdApp As Word.Application, strFileName$, strPath$, vTemp1, vTemp
    Dim ar, br, cr, i&, j&, n&, k&, strSaveName$, dic As Object, vKey
   
    ' 获取模板文件路径
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "采购模版.docx"
   
    ' 检查模板文件是否存在
    If Dir(strFileName) = "" Then
        MsgBox "模板文件不存在，请检查！", vbExclamation
        Exit Sub
    End If
   
    ' 关闭屏幕更新，提高性能
    Application.ScreenUpdating = False
    On Error Resume Next
   
    ' 创建字典对象
    Set dic = CreateObject("Scripting.Dictionary")
   
    ' 从第二行开始，将数据存入字典
    ar = Worksheets(2).[A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        ' 将数据按照第一列的值存入字典中
        dic(ar(i, 1)) = dic(ar(i, 1)) & " " & i
    Next i
   
    ' 将每个键对应的值转换为二维数组
    For Each vKey In dic.keys
        cr = Split(dic(vKey))
        ReDim br(1 To UBound(cr), 1 To UBound(ar, 2) - 1)
        For i = 1 To UBound(cr)
            For j = 1 To UBound(br, 2)
                ' 从工作表中获取数据并存入二维数组
                br(i, j) = ar(cr(i), j + 1)
            Next j
        Next i
        ' 将二维数组存回字典中
        dic(vKey) = br
    Next
   
    ' 从第一个工作表获取数据
    ar = Worksheets(1).[A1].CurrentRegion.Value
   
    ' 获取或创建Word应用程序实例
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
    End If
   
    ' 遍历数据并填充到Word模板中
    For i = 2 To UBound(ar)
        With wdApp.documents.Open(strFileName)
            ' 为每一行数据创建一个新的Word文档
            strSaveName = strPath & ar(i, 1) & "_" & Format(Now(), "yyyymmddhhnnss")
            
            ' 填充数据到Word模板中
            For j = 1 To UBound(ar, 2)
                With .Content.Find
                    .ClearFormatting
                    .Text = "数据" & Format(j, "000")
                    .Replacement.Text = ar(i, j)
                    .Execute Replace:=wdReplaceAll
                End With
            Next j
            
            ' 如果键存在于字典中，则处理表格和特定文本
            If dic.Exists(ar(i, 1)) Then
                br = dic(ar(i, 1))
                With .Tables(1)
                    ' 添加行并填充数据
                    For j = 1 To UBound(br) + 1
                        .Rows.Add
                    Next
                    For k = 1 To UBound(br)
                        For j = 1 To UBound(br, 2)
                            .Cell(k + 1, j).Range.Text = br(k, j)
                        Next j
                    Next k
                    n = UBound(br) + 2
                    .Cell(n, 4).Merge .Cell(n, 4).Next
                    .Cell(n, 2).Range.Text = "合计"
                    .Cell(n, 3).Range.Text = WorksheetFunction.Sum(Application.Index(br, , 3))
                    .Cell(n, 4).Range.Text = ar(i, 3)
                    vTemp = WorksheetFunction.Sum(Application.Index(br, , 6))
                    vTemp1 = vTemp
                    .Cell(n, 5).Range.Text = vTemp
                    vTemp = digitToDx(CCur(vTemp))
                End With
                ' 替换特定文本
                With .Content.Find
                    .ClearFormatting
                    .Text = "数据031"
                    .Execute
                    If .Found = True Then
                        .Parent.Text = "人民币" & vTemp & "（￥：" & vTemp1 & "元）"
                    End If
                End With
            End If
            ' 保存并关闭文档
            .SaveAs strSaveName
            .Close
        End With
    Next i
   
    ' 如果发生错误，退出Word应用程序
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    Beep
End Sub
我希望能够隐藏该行，怎么修改代码？