按模板每3个单号批量打印

fanion

求助：(详见附件内容)

     1.数据从磅单记录表引用；
     2.打印单据号按G1到G3的要求连续打印；
     3.以左边模板每页3张数据记录号的数据连续输出打印，直至上述G1到G2的单号打印完。
         感谢老师给予帮助！

饮冰e士

建议加入“当前号”，根据当前号在表格中写上公式，然后循环切换当前号就可以了。

醉眼看尘世

1. Sub Test()
   
2. Dim mBrr(1 To 8, 1 To 5), Arr, Brr, i&, j&, StarTNumber, EndNumBer, x, tmProw%
   
3. 
   
4. For i = 1 To 8
   
5.     mBrr(i, 1) = Array("单位:KG", "车       号", "货       名", "发货区域", "发货单位", "收货单位", "承运单位", "过  磅  员")(i - 1)
   
6.     mBrr(i, 3) = Array("", "毛       重", "皮       重", "净       重", "毛重时间", "皮重时间", "实际净重", "备        注")(i - 1)
   
7. Next i
   
8. mBrr(2, 1) = "记录时间:": mBrr(4, 1) = "单据号:"
   
9. 
   
10. 
    
11. Arr = Sheet11.[a1].CurrentRegion
    
12. 
    
13. With Sheet1
    
14.     StarTNumber = .[g1] & ""
    
15.     EndNumBer = .[g3] & ""
    
16.     x = 0
    
17.     For i = 2 To UBound(Arr, 1)
    
18.         If Arr(i, 1) & "" >= StarTNumber And Arr(i, 1) & "" <= EndNumBer Then
    
19.             x = x + 1
    
20.             If x = 1 Then Call 模板清空
    
21.             
    
22.             Brr = mBrr
    
23.             For j = 1 To 6
    
24.                 Brr(j + 1, 2) = Arr(i, j + 2)
    
25.             Next j
    
26.             For j = 2 To 7
    
27.                 Brr(j, 4) = Arr(i, j + 7)
    
28.             Next j
    
29.             Brr(1, 3) = Arr(i, 2)
    
30.             Brr(1, 5) = Arr(i, 1)
    
31.             Brr(8, 2) = Arr(i, 15): Brr(8, 4) = Arr(i, 16)
    
32.             tmProw = Array(4, 16, 28)(x - 1)
    
33.             .Cells(tmProw, 1).Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr
    
34.             If x = 3 Then .PrintOut: x = 0
    
35.         End If
    
36.     Next i
    
37.     If x Then .PrintOut
    
38. End With
    
39. End Sub

复制代码

醉眼看尘世

Brr(1, 3) = Arr(i, 2)改成 Brr(1,4) = Arr(i, 2)

fanion

醉眼看尘世 发表于 2024-8-26 18:12

感谢老师的解答，能否帮我再改改，模板中单元格已经显示的文字不清除也不在代码中显示，以方便你写的代码能在后续其他单据模板中移植，多谢了！

Qs18

Sub qs()
Dim arr, i
arr = Sheet11.Range("a1").CurrentRegion.Value
Call 模板清空
With Sheet1
ks = .Range("G1").Value
js = .Range("g3").Value
br = [{4,16,28}]
For i = 2 To UBound(arr)
    If ks = arr(i, 1) Then rw = i
    If js = arr(i, 1) Then rw2 = i
    If rw > 0 And rw2 > 0 Then Exit For
Next
For i = rw To rw2
        y = y + 1
        m = br(y)
        .Cells(m, 3) = arr(i, 2): .Cells(m, 5) = arr(i, 1)
        For j = 1 To 6
            m = m + 1
            .Cells(m, 2).Value = arr(i, j + 2)
            .Cells(m, 4).Value = arr(i, j + 8)
        Next
            .Cells(m + 1, 2).Value = arr(i, 15)
            .Cells(m + 1, 4).Value = arr(i, 16)
        If y = 3 Then .PrintOut: y = 0
Next
If y > 0 Then .PrintOut
End With
End Sub

Qs18

试试...........

Qs18

试试..........

醉眼看尘世

1. Sub Test()
   
2. Dim Arr, Brr, i&, j&, StarTNumber, EndNumBer, x, tmProw
   
3. Call 模板清空
   
4. Brr = Sheet1.[a4:E11]
   
5. Arr = Sheet11.[a1].CurrentRegion
   
6. With Sheet1
   
7.     StarTNumber = .[g1] & ""
   
8.     EndNumBer = .[g3] & ""
   
9.     x = 0
   
10.     For i = 2 To UBound(Arr, 1)
    
11.         If Arr(i, 1) & "" >= StarTNumber And Arr(i, 1) & "" <= EndNumBer Then
    
12.             x = x + 1
    
13.             If x = 1 Then Call 模板清空
    
14.             For j = 1 To 6
    
15.                 Brr(j + 1, 2) = Arr(i, j + 2)
    
16.             Next j
    
17.             For j = 2 To 7
    
18.                 Brr(j, 4) = Arr(i, j + 7)
    
19.             Next j
    
20.             Brr(1, 4) = Arr(i, 2)
    
21.             Brr(1, 5) = Arr(i, 1)
    
22.             Brr(8, 2) = Arr(i, 15): Brr(8, 4) = Arr(i, 16)
    
23.             tmProw = Array(4, 16, 28)(x - 1)
    
24.             .Cells(tmProw, 1).Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr
    
25.             If x = 3 Then .PrintOut: x = 0
    
26.         End If
    
27.     Next i
    
28.     If x Then .PrintOut
    
29. End With
    
30. End Sub
    

复制代码

Qs18

Sub qs()
Dim arr, i
arr = Sheet11.Range("a1").CurrentRegion.Value
With Sheet1
ks = .Range("G1").Value
js = .Range("g3").Value
br = [{4,16,28}]
For i = 2 To UBound(arr)
    If ks = arr(i, 1) Then rw = i
    If js = arr(i, 1) Then rw2 = i
    If rw > 0 And rw2 > 0 Then Exit For
Next
For i = rw To rw2
        y = y + 1
        If y = 1 Then Call 模板清空
        m = br(y)
        .Cells(m, 3) = arr(i, 2): .Cells(m, 5) = arr(i, 1)
        For j = 1 To 6
            m = m + 1
            .Cells(m, 2).Value = arr(i, j + 2)
            .Cells(m, 4).Value = arr(i, j + 8)
        Next
            .Cells(m + 1, 2).Value = arr(i, 15)
            .Cells(m + 1, 4).Value = arr(i, 16)
        If y = 3 Then .PrintOut: y = 0
Next
If y > 0 Then .PrintOut
End With
End Sub
‘后面这个是修改后的