求助论坛老师解决下

1013182120

这个代码生成的是单独的word文档，想要实现的是生成的文档都在一个word里面，请老师们出手解决下

3190496160

Sub 生成word记录表()
Application.ScreenUpdating = False
Dim wdApp As Object, wdDoc As Object
Set d = CreateObject("scripting.dictionary")
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
lj = ThisWorkbook.Path & "\"
mb = Dir(lj & "数据.docx")
If mb = "" Then MsgBox "": End
arr = Sheets("Sheet1").Range("A1:s" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 2 To UBound(arr)
    zf = Trim(arr(i, 1))
    If Trim(zf) <> "" Then
        d(zf) = ""
    End If
Next i
Set wdDoc = wdApp.Documents.Open(lj & "数据.docx")
With wdApp
    .ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '设置位置在正文
    .Selection.WholeStory '全选
    .Selection.Copy '复制
    For i = 0 To d.Count - 2
        .Selection.EndKey Unit:=6 'wdStory '光标置于文件尾
        '.Selection.InsertBreak Type:=wdPageBreak '分页
        .Selection.PasteAndFormat (wdPasteDefault) '粘贴
    Next i
End With
For Each k In d.keys
    n = 0: m = m + 1
    ReDim br(1 To UBound(arr), 1 To UBound(arr, 2))
    For i = 2 To UBound(arr)
        If Trim(arr(i, 1)) = k Then
            n = n + 1
            For j = 1 To UBound(arr, 2)
                br(n, j) = arr(i, j)
            Next j
        End If
    Next i
    xh = 4
    With wdDoc.Tables(m)
        For i = 1 To n
            .Cell(1, 4).Range.Text = k
            .Cell(1, 2).Range.Text = br(i, 3)
            .Cell(10, 3).Range.Text = br(i, 13)
            .Cell(10, 4).Range.Text = br(i, 17)
            .Cell(10, 5).Range.Text = "鉴别检验损耗" & br(i, 19) & "条"
            xh = xh + 1
            .Cell(xh, 1).Range.Text = br(i, 10)
            .Cell(xh, 2).Range.Text = br(i, 16)
            .Cell(xh, 3).Range.Text = br(i, 13)
            .Cell(xh, 4).Range.Text = br(i, 11)
            .Cell(xh, 5).Range.Text = "鉴别检验损耗" & br(i, 15) & "条"
            If xh + 1 < 10 Then .Cell(xh + 1, 1).Range.Text = "以下空白......"
        Next i
    End With
Next k
wdDoc.SaveAs Filename:=lj & "记录表" & Format(Date, "yyyymmdd"), FileFormat:=wdFormatDocumentDefault
wdDoc.Close SaveChanges:=False
wdApp.Quit
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

text.rar (52.29 KB, 下载次数: 13)

2024-5-9 09:40 上传

点击文件名下载附件

1013182120

3190496160 发表于 2024-5-9 09:40

是我要的效果  谢谢老师