批量打印数据

cjzhangyong

模板工作表为套打的模版
1、根据数据工作表中的单据号产生销售出库单
2、一张出库单模版最多可以打印13行，对于一个单据号超过13行的需要增加第二张一张出库单 第二张单据右边显示2/2(意思就是共2张，此份为第2张），超过26行的需要增加第三张，以此类推。


原来的宏代码对数据量比较大运行就比较慢，原来代码是否可以优化。

3190496160

目前的diam直接操作单元格肯定慢，但是要修改目前的代码几乎是不可能的，先留个记号吧

chengyunpan

万能批量软件用于楼主的案例

软件简介：   
     真正的软件级别，VBA通用软件，用于批量打印、拆分，用于特殊需求的录入、打印等等。不需改代码，就可以万能套用。复杂的数据引用、格式要求都能简单解决。
      单个、少量、批量操作（打印、拆分等）或者选择性操作都一样方便。
      核心很简单，就是用“=”号引用对应数据列，并作简单设置，一学就会，很容易套用到工作中遇到的实际案例。
       界面超级简单，千篇一律，傻瓜式操作。
      每个案例都仅是此软件的一个小应用，学会一个案例作参考就能一里通百里用，欢迎大家测试使用，更期待能提出宝贵意见。
     软件免费，并附简易教程，需要做简单设计才能吻合到实际案例。也可以联系作者提供设计服务，能为你提供完美的整体解决方案。
      文件就是软件！！！

wengjl

请参考
https://club.excelhome.net/threa ... tml?_dsign=68639f0d

3190496160

Sub 销售单()
Application.ScreenUpdating = False
Dim ar As Variant
Dim rn As Range
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
With Sheets("数据")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "数据为空！": End
    ar = .Range("a1:x" & r)
End With
For i = 2 To UBound(ar)
    If ar(i, 1) <> "" Then
        If Not d.exists(ar(i, 1)) Then Set d(ar(i, 1)) = CreateObject("scripting.dictionary")
        d(ar(i, 1))(i) = ""
    End If
Next i
Set rn = Sheets("模板").Rows("1:22")
With Sheets("结果")
    .UsedRange.Clear
    m = 1
    For Each k In d.keys
        n = 0
        ReDim br(1 To UBound(ar), 1 To 29)
        For Each kk In d(k).keys
            n = n + 1
            br(n, 1) = n
            br(n, 2) = ar(kk, 10)
            br(n, 7) = ar(kk, 11)
            br(n, 17) = ar(kk, 12)
            br(n, 19) = ar(kk, 13)
            br(n, 22) = ar(kk, 14)
            br(n, 25) = ar(kk, 15)
            br(n, 28) = ar(kk, 16)
            br(n, 29) = ar(kk, 17)
            kh = ar(kk, 3)
            rq = ar(kk, 8)
        Next kk
        If n <= 13 Then
            rn.Copy .Cells(m, 1)
            .Cells(m + 3, 3) = k
            .Cells(m + 3, 10) = kh
            .Cells(m + 3, 24) = rq
            .Cells(m + 5, 1).Resize(n, UBound(br, 2)) = br
            m = m + 22
        Else
            ss = 0
            If n / 13 = Int(n / 13) Then
                sl = n / 13
            Else
                sl = Int(n / 13) + 1
            End If
            For i = 1 To n Step 13
                ss = ss + 1
                rn.Copy .Cells(m, 1)
                .Cells(m + 3, 3) = k
                .Cells(m + 3, 10) = kh
                .Cells(m + 3, 24) = rq
                .Cells(m + 1, 30) = ss & " / " & sl
                tt = m + 4
                For s = i To i + 12
                    If s <= n Then
                        tt = tt + 1
                        For j = 1 To UBound(br, 2)
                            .Cells(tt, j) = br(s, j)
                        Next j
                    End If
                Next s
                m = m + 22
            Next i
        End If
    Next k
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

2212销售出库单模版.rar (228.38 KB, 下载次数: 24)

2024-6-19 09:37 上传

点击文件名下载附件

cjzhangyong

3190496160 发表于 2024-6-19 09:37

谢谢写的代码，研究下思路

wang-way

用一个一点记录同一个单据的行数，每满13就创建一页。

wang-way

哈哈哈哈哈哈  我来练个手  从此彻底无忧

wanao2008

感谢这位网友的支持与肯定，代码如下：

1. Sub InsertSheet(m&)
   
2.     Sheet2.Range("A1:AE22").Copy Sheet4.Range("A" & ReturnRow(m))
   
3. End Sub
   
4. 
   
5. Function ReturnRow(m&)
   
6.     ReturnRow = (m - 1) * 22 + 1
   
7. End Function
   
8. 
   
9. Sub byWanao()
   
10.     Dim i&, j&, k&, m&, n&, rNum&
    
11.     Dim Dic As Object, arr, brr, crr(1 To 100)
    
12.     Application.ScreenUpdating = False
    
13.     Set Dic = CreateObject("Scripting.Dictionary")
    
14.     arr = Sheet3.Range("A1").CurrentRegion
    
15.     For i = 2 To UBound(arr)
    
16.         If Not Dic.exists(arr(i, 1)) Then
    
17.             n = 1
    
18.             k = k + 1
    
19.             crr(k) = 1
    
20.             Dic(arr(i, 1)) = k
    
21.             InsertSheet k
    
22.             m = k
    
23.         Else
    
24.             m = Dic(arr(i, 1))
    
25.             If crr(m) >= 13 Then
    
26.                 n = n + 1
    
27.                 crr(m) = 13
    
28.                 k = k + 1
    
29.                 Dic(arr(i, 1)) = k
    
30.                 InsertSheet k
    
31.                 m = k
    
32.                 For j = 1 To n
    
33.                     Sheet4.Cells(ReturnRow(m - n + j) + 1, 30) = j & "/" & n
    
34.                 Next
    
35.             End If
    
36.             crr(m) = crr(m) + 1
    
37.         End If
    
38.         
    
39.         rNum = ReturnRow(m)
    
40.         With Sheet4
    
41.             .Cells(rNum + 3, 1) = "单 据 号：" & arr(i, 1)
    
42.             .Cells(rNum + 3, 8) = "客 户：" & arr(i, 3)
    
43.             .Cells(rNum + 3, 23) = "日 期：" & arr(i, 8)
    
44.             .Cells(rNum + crr(m) + 4, 2) = arr(i, 10)
    
45.             .Cells(rNum + crr(m) + 4, 7) = arr(i, 11)
    
46.             .Cells(rNum + crr(m) + 4, 17) = arr(i, 12)
    
47.             .Cells(rNum + crr(m) + 4, 19) = arr(i, 13)
    
48.         End With
    
49.     Next
    
50.     Application.ScreenUpdating = True
    
51. End Sub
    

复制代码

附件：
2212销售出库单模版.rar (71.19 KB, 下载次数: 9)

2024-6-26 19:39 上传

点击文件名下载附件

代码写的充忙，还没优化。
我用的是你隐藏的那个表格。