根据运单明细和打印模板，创建一个可连续打印的磅单

ttiemike

请大家帮忙写一段VBA代码，要求如下：
1、本工作簿有3个工作表，分别为SHEET1运单明细,SHEET2可批量打印的磅单,SHEET3打印模板;
2、VBA代码的主要目标是:根据运单明细和打印模板，将运单明细的每一行数据创建一个可连续打印的磅单；

拜托啦

olin12345

循环直接打印更好吧，可以省去打印榜单的页面。直接利用明细和模板。

quqiyuan

参与一下，仅供参考。。。
速度有点慢

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet, sh1 As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("运单明细")
    Set sh = wb.Sheets("打印模板")
    Set sh1 = wb.Sheets("可批量打印的磅单")
    arr = sht.[a1].CurrentRegion
    Set Rng = sh.[a1:g9]
    For i = 2 To UBound(arr)
        sh.[e2] = arr(i, 7)
        sh.[b4] = arr(i, 3)
        sh.[b5] = arr(i, 4)
        sh.[b6] = arr(i, 5)
        sh.[e4] = arr(i, 6)
        sh.[g4] = arr(i, 1)
        sh.[g7] = arr(i, 9)
        sh.[b8] = arr(i, 10)
        r = sh1.Cells(Rows.Count, 1).End(3).Row
        r = IIf(r = 1, 1, r + 2)
        Rng.Copy sh1.Cells(r, 1)
    Next
    Rng.Copy
    sh1.Cells(r, 1).PasteSpecial 8      '调整列宽
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "共耗时：" & Format(Timer - t, "0.0000") & " 秒！！！", 64
End Sub

ttiemike

quqiyuan 发表于 2025-4-11 15:31
参与一下，仅供参考。。。
速度有点慢

非常感谢神侠quqiyuan，正是满足我所需要的，请帮忙添加几句代码，做到每页只打印一份磅单。

quqiyuan

ttiemike 发表于 2025-4-11 15:59
非常感谢神侠quqiyuan，正是满足我所需要的，请帮忙添加几句代码，做到每页只打印一份磅单。

添加个插入分页符代码，仅供参考。。。

quqiyuan

代码如下，，，
Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet, sh1 As Worksheet
    Set wb = ThisWorkbook
    Set sht = wb.Sheets("运单明细")
    Set sh = wb.Sheets("打印模板")
    Set sh1 = wb.Sheets("可批量打印的磅单")
    arr = sht.[a1].CurrentRegion
    Set rng = sh.[a1:g9]
    For i = 2 To UBound(arr)
        sh.[e2] = arr(i, 7)
        sh.[b4] = arr(i, 3)
        sh.[b5] = arr(i, 4)
        sh.[b6] = arr(i, 5)
        sh.[e4] = arr(i, 6)
        sh.[g4] = arr(i, 1)
        sh.[g7] = arr(i, 9)
        sh.[b8] = arr(i, 10)
        r = sh1.Cells(Rows.Count, 1).End(3).Row
        r = IIf(r = 1, 1, r + 2)
        rng.Copy sh1.Cells(r, 1)
    Next
    rng.Copy
    sh1.Cells(r, 1).PasteSpecial 8      '调整列宽
    Call PageBreaks
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "共耗时：" & Format(Timer - t, "0.0000") & " 秒！！！", 64
End Sub


Sub PageBreaks()
    Dim rng_find As Range, rng As Range
    With ThisWorkbook.Sheets("可批量打印的磅单")
        .ResetAllPageBreaks
        r = .Cells(.Rows.Count, 1).End(3).Row
        With .PageSetup
            .PrintArea = "a1:g" & r
            n = 0
            .Zoom = 100
'            .CenterVertically = True
            .CenterHorizontally = True
            .Orientation = xlPortrait
        End With
        Windows(ThisWorkbook.Name).View = xlPageBreakPreview
        x = .HPageBreaks.Count
        For i = 11 To r Step 10
            .HPageBreaks.Add .Rows(i)
        Next
'        .PageSetup.FitToPagesWide = 1
'        .PrintPreview
    End With
    Windows(ThisWorkbook.Name).View = xlNormalView
End Sub

3190496160

Sub 批量生成磅单()
Application.ScreenUpdating = False
Dim ar As Variant
With Sheets("运单明细")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "运单明细为空！": End
    ar = .Range("a1:j" & r)
End With
With Sheets("打印模板")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs > 53 Then .Rows("54:" & rs).Delete
    m = 54
    For i = 2 To UBound(ar)
        .Rows("1:53").Copy .Cells(m, 1)
        m = m + 53
    Next i
    m = 1
    For i = 2 To UBound(ar)
        .Cells(m + 1, 5) = ar(i, 7)
        .Cells(m + 3, 2) = ar(i, 3)
        .Cells(m + 4, 2) = ar(i, 4)
        .Cells(m + 5, 2) = ar(i, 5)
        .Cells(m + 3, 5) = ar(i, 6)
        .Cells(m + 3, 7) = ar(i, 1)
        .Cells(m + 6, 7) = ar(i, 9)
        .Cells(m + 7, 2) = ar(i, 10)
        m = m + 53
    Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

可连续打印车运磅单.rar (29.44 KB, 下载次数: 21)

2025-4-11 17:28 上传

点击文件名下载附件

3190496160

一张A4纸一张磅单，供参考