根据明细自动生成送货单并截图保存到表的目录下

csp1220

根据明细自动生成送货单并截图保存到表的目录下

csp1220

高手路过，请留下痕迹。

魂断蓝桥

Option Explicit
Sub toJPG()
    Dim myf
    myf = [h2]
    Application.ScreenUpdating = False
    Range("a1:i22").Select
    Range("a1:i22").CopyPicture
    With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width, Selection.Height).Chart
        .Paste
        .Export ThisWorkbook.Path & "\" & myf & ".JPG", "JPG"
        .Parent.Delete
    End With
    Application.ScreenUpdating = True
    MsgBox ("OK")
End Sub

芐雨

新建一个工作表，做个空白的送货单


送货单求助.zip (41.52 KB, 下载次数: 32)

2019-12-25 09:55 上传

点击文件名下载附件

1. Sub DeliveryNote()
   
2.     Dim sPath$
   
3.     Dim lorw&, i&, j&, n&
   
4.     Dim arr, brr, shap
   
5.    
   
6.     lrow = Sheets("明细").Cells(Rows.Count, 1).End(3).Row + 1
   
7.    
   
8.     arr = Sheets("明细").Range("A1:I" & lrow)
   
9.    
   
10.     brr = Sheets("空白发货单").Range("A1:I22") '做一个空白发货单
    
11.    
    
12.     sPath = ThisWorkbook.Path & ""
    
13.     n = 6
    
14.     For i = 2 To UBound(arr) - 1
    
15.         n = n + 1
    
16.         
    
17.         brr(2, 8) = arr(i, 1) '单据编号
    
18.         brr(2, 2) = arr(i, 2) '开单日期
    
19.         brr(4, 3) = arr(i, 3) '客户名称
    
20.         brr(n, 1) = arr(i, 5) '货品名称
    
21.         brr(n, 3) = arr(i, 6) '规格
    
22.         brr(n, 5) = arr(i, 7) '数量
    
23.         brr(n, 6) = arr(i, 8) '单价
    
24.         brr(n, 7) = arr(i, 9) '价格
    
25.         
    
26.         brr(17, 5) = arr(i, 7) + brr(17, 5) '数量合计
    
27.         brr(17, 7) = arr(i, 9) + brr(17, 7)  '合计
    
28.         brr(17, 8) = brr(17, 7)  '合计
    
29.         
    
30.         If arr(i, 1) <> arr(i + 1, 1) Then
    
31.             
    
32.             brr(18, 2) = RMBdx(brr(17, 7))   '转大写
    
33.             
    
34.             With Sheets("发货单")
    
35.                 .Range("A1:I22") = brr
    
36.                 .Range("A1:I22").Copy
    
37.                 Set shap = ActiveSheet.Pictures.Paste
    
38.                 shap.Copy  '//复制图片
    
39.                
    
40.                 With ActiveSheet.ChartObjects.Add(0, 0, shap.Width, shap.Height).Chart  '//建立一个新图片
    
41.                     Savetime = Timer '记下开始的时间
    
42.                     While Timer < Savetime + 1 '循环等待
    
43.                         DoEvents '转让控制权，以便让处理其它的事件。
    
44.                     Wend
    
45.                     .Paste  '//将复制的图片放进去
    
46.                     .Export sPath & brr(2, 8) & ".JPG" '//导出为图片格式，如JPG，GIF
    
47.                     .Parent.Delete   '//删除自己建立的图片
    
48.                 End With
    
49.             End With
    
50.             shap.Delete
    
51.             n = 6
    
52.             brr = Sheets("空白发货单").Range("A1:I22")
    
53.         End If
    
54.     Next
    
55.    
    
56.     MsgBox "已生成图片!"
    
57. End Sub
    
58. 
    
59. Function RMBdx(Optional Mynum As Variant)
    
60.     If IsNumeric(Mynum) = False Then
    
61.         Mynum = 0
    
62.     End If
    
63.     Mynum = Round(Mynum, 2)
    
64.     If Sgn(Mynum) = 0 Then
    
65.         RMBdx = ""
    
66.     Else
    
67.         RMBdx = IIf(Sgn(Mynum) = -1, "负", "") & Application.Text(Int(Abs(Mynum)), "[=]g;[dbnum2]") & "圆"
    
68.         If Abs(Mynum) - Int(Abs(Mynum)) > 0 Then
    
69.             RMBdx = RMBdx & Application.Text(Right(Format(Abs(Mynum) - Int(Abs(Mynum)), "0.00"), 2), "[=]g;[dbnum2]0角0分")
    
70.             RMBdx = Replace(Replace(RMBdx, "零分", ""), "零角", "零")
    
71.         Else
    
72.             RMBdx = RMBdx & "整"
    
73.         End If
    
74.     End If
    
75. End Function
    

复制代码

csp1220

芐雨 发表于 2019-12-25 09:57
新建一个工作表，做个空白的送货单

感谢。我试一下。

csp1220

芐雨 发表于 2019-12-25 09:57
新建一个工作表，做个空白的送货单

高手，截图能否就截最近一个发货单？另外单号是12-02-0001，12-03-0001，怎么来设？

csp1220

芐雨 发表于 2019-12-25 09:57
新建一个工作表，做个空白的送货单

高手。我只需要最新的发货单并截图。VBA怎么设？

zjgzfs

用Word的“邮件合并”不就行了吗？

csp1220

zjgzfs 发表于 2019-12-27 13:02
用Word的“邮件合并”不就行了吗？

平时的工作都是用EXCEL表。

zjgzfs

csp1220 发表于 2019-12-27 16:49
平时的工作都是用EXCEL表。

可以将Excel 工作表中的表格，直接复制、粘贴到Word中，然后复用“邮件合并”即可解决。
我的看法：能用Word、Excel 中现在的功能、函数等解决的问题，就尽量不要用VBA编程，毕竟编程比较麻烦，而且执行效率不如Excel 内置函数高。