根据EXCEL表自动生成购销合同文件

3190496160

Sub 生成购销合同()
Dim appWD, doc As Object, f, arr, i, j, r
Dim rn As Range
With Sheets("外销报关出口明细报表")
    r = .Cells(Rows.Count, 4).End(xlUp).Row
    ws = .Range("a4:h" & r).Find("合计", , , , , , , 1).Row
    ar = .Range("a4:aa" & ws)
End With
rr = Array(4, 26, 27, 24, 23)
Set appWD = CreateObject("Word.Application")
f = ThisWorkbook.Path & "\购销合同模版.docx"
For i = 2 To UBound(ar)
    If ar(i, 4) <> "" Then
        ht = ar(i, 4)
        FileCopy f, ThisWorkbook.Path & "\购销合同\购销合同" & ht & ".docx"
        Set doc = appWD.Documents.Open(ThisWorkbook.Path & "\购销合同\购销合同" & ht & ".docx")
        appWD.Visible = True
        m = 0
        With appWD
            For s = 0 To UBound(rr)
                m = m + 1
                lh = rr(s)
                Str1 = "sj" & m
                .Selection.HomeKey Unit:=6 '光标置于文件首
                If .Selection.Find.Execute(Str1) Then '查找到指定字符串
                   .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
                   .Selection.Text = ar(i, lh) '替换字符串
                End If
            Next s
            .ActiveDocument.Tables(1).Cell(2, 2).Range = ar(i, 4)
            .ActiveDocument.Tables(1).Cell(2, 3).Range = ar(i, 8)
            .ActiveDocument.Tables(1).Cell(2, 5).Range = ar(i, 9)
            .ActiveDocument.Tables(1).Cell(4, 4).Range = ar(i, 9)
        End With
        doc.Close True
    End If
Next i
appWD.Quit
MsgBox "ok!"
End Sub

3190496160

生成word文档
合同文件 (2).rar (164.72 KB, 下载次数: 17)

2025-3-25 10:12 上传

点击文件名下载附件

wulin588

3190496160 发表于 2025-3-25 10:12
生成word文档

感谢老师！这个word 版也挺好的，就是有点小问题，麻烦您修改一下（订单编号不用取数，尺寸/英寸取的数移到右边数量那个格子，我小白不好意思。

wulin588

翁知江安 发表于 2025-3-24 21:24
Sub test()
Dim i As Integer
Dim ar As Variant

老师：感谢您！我测试了一下，还是挺好用的。发现有个小问题，如果把源数据中某行数据删掉（空着的），生成的合同就只有这个无数据的行之上的可以生成购销合同。麻烦您修改一下，谢谢了！

翁知江安

Sub test()
Dim i As Integer
Dim ar As Variant
Dim rng, s
Dim wb As Workbook
Dim p As String
p = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set rng = ThisWorkbook.Sheets("购销合同模版").Range("a1:f37")
ar = ThisWorkbook.Sheets("外销报关出口明细报表").UsedRange
For i = 5 To UBound(ar)
   If ar(i, 2) <> "" Then
     rng.Copy ThisWorkbook.Sheets("购销合同模版").[a1]
     With ThisWorkbook.Sheets("购销合同模版")
     .[f4] = ar(i, 4)
     .[c5] = ar(i, 26)
     .[c10] = ar(i, 8)
     .[f10] = ar(i, 9)
     .[d15] = ar(i, 24)
     .[c14] = ar(i, 27)
     .[c37] = ar(i, 23)
     .Copy
      End With
     Set wb = ActiveWorkbook
     s = "购销合同" & ar(i, 4)
     wb.Sheets("购销合同模版").Name = s
     wb.SaveAs p & "购销合同" & ar(i, 4) & ".xlsx"
     wb.Close False
     End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "ok"
End Sub

翁知江安

这是修改后，供参考。

wulin588

翁知江安 发表于 2025-3-25 12:24
这是修改后，供参考。

老师：您好！麻烦下您发下文件，谢谢！

翁知江安

文件夹中有个字文件夹备查，是将原来的数据打包。请知悉

wulin588

翁知江安 发表于 2025-3-25 12:23
Sub test()
Dim i As Integer
Dim ar As Variant

老师：VBA很完美，感谢了！好人一生平安！

wulin588

翁知江安 发表于 2025-3-25 13:28
文件夹中有个字文件夹备查，是将原来的数据打包。请知悉

好的，谢谢您！