单据套打

anywhere99

求助各位大神，销售发货单套打，如何实现客户的订单批量打印，双方确认用。



要求：
1、蓝色部分根据明细直接代入，LOGO根据LOGO列表自动代入图片
2、绿色部分根据代入的明细自动合计
3、要求行主要内容即从第8行开始，最多可以打印48行，余有2行为合计和大写列明，超过48行自动转至下页打印完成，如有超页再做换页同样的操作


谢谢

anywhere99

打印在A4纸上

liulang0808

Sub test()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("明细").UsedRange
    crr = Array(1, 7, 4, 8, 7, 9, 8, 10, 10, 11, 12, 12, 13, 13, 14, 14)
    Application.ScreenUpdating = False
    Sheets("套打格式").Select
    For j = 2 To UBound(arr)
        d(arr(j, 1)) = d(arr(j, 1)) & "#" & j
    Next
    For Each k In d.keys
        brr = Split(d(k), "#")
        clear_pic
        Call addpic(k)
        x = Val(brr(1))
        [n2] = k
        [n3] = arr(x, 2)
        [c5] = arr(x, 3)
        [b6] = "地址电话:" & arr(x, 4)
        [k5] = "公司名称：" & arr(x, 5)
        [k6] = "地址电话：" & arr(x, 6)
        cont_clear
        For j = 1 To UBound(brr)
            r = (j - 1) Mod 30 + 8
            x = Val(brr(j))
            For i = 0 To UBound(crr) Step 2
                Cells(r, crr(i)) = arr(x, crr(i + 1))
            Next i
            If j Mod 30 = 0 Or j = UBound(brr) Then
                If r < 37 Then
                    Rows(r + 1 & ":" & 37).EntireRow.Hidden = True
                End If
                [a1:n41].PrintOut
                cont_clear
            End If
        Next j
    Next k
    Application.ScreenUpdating = True
End Sub
Sub add_cont(arr, brr, j, k)
    [n2] = k
    x = Val(brr(j))
    [c5] = arr(x, 3)
End Sub
Sub cont_clear()
    [a8:n37].ClearContents
    [a8:n37].EntireRow.Hidden = False
   
End Sub
Sub clear_pic()
    For Each shp In ActiveSheet.Shapes
        shp.Delete
    Next shp
End Sub
Sub addpic(k)
    For Each shp In Sheets("LOGO").Shapes
        yy = shp.TopLeftCell.Offset(0, -1).Value
        If yy = k Then
            shp.Copy
            ActiveSheet.Paste
            With Selection
                .Top = [b2].Top
                .Left = [b2].Left
                .Width = [b2].Width
                .Height = [b2:b3].Height
            End With
            [a4].Select
            Exit For
        End If
    Next shp
End Sub

liulang0808

套打格式.zip (58.24 KB, 下载次数: 45)

2024-3-6 20:48 上传

点击文件名下载附件

具体楼主可以根据自己的需求再调整的

熊文来

liulang0808 发表于 2024-3-6 20:47
Sub test()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("明细").UsedRange

最近都没怎么来这里，一来就看到您的优秀作品。

anywhere99

能不能给在内容里加一个按键啊

anywhere99

谢谢大神支持
还请帮忙：
1、增加设置套打的内容行数根据实际明细的行数，自动调节，如果超过48行就余下的转下页
2、引用的LOGO大小设置固定尺寸2cm*2cm
3、给文件内容加一个按键，方便操作

谢谢

山海风云轩

学习学习      

3190496160

Sub 批量打印()
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
ar = Sheets("明细").[a1].CurrentRegion
For i = 2 To UBound(ar)
    If ar(i, 1) <> Empty Then
        If d(ar(i, 1)) = "" Then
            d(ar(i, 1)) = i
        Else
            d(ar(i, 1)) = d(ar(i, 1)) & "|" & i
        End If
    End If
Next i
rr = Array(1, 4, 7, 8, 10, 12, 13, 14)
For Each k In d.keys
    For Each shp In ActiveSheet.Shapes
        If shp.TopLeftCell.Column < 14 Then
            shp.Delete
        End If
    Next shp
    For Each shp In Sheets("LOGO").Shapes
        y = shp.TopLeftCell.Offset(0, -1).Value
        If y = k Then
            Sheets("LOGO").Select
            shp.Copy
            Sheets("套打格式").Activate
            Range("B2").Select
            ActiveSheet.Paste
            With Selection
                .Top = [b2].Top
                .Left = [b2].Left
                .Width = [b2].Width
                .Height = [b2:b3].Height
            End With
            [a4].Select
            Exit For
        End If
    Next shp
    [a8:n45].ClearContents
    [a8:n45].EntireRow.Hidden = False
    br = Split(d(k), "|")
    sl = UBound(br) + 1
    x = br(0)
    [n2] = k
    [n3] = ar(x, 2)
    [c5] = ar(x, 3)
    [b6] = "地址电话:" & ar(x, 4)
    [k5] = "公司名称：" & ar(x, 5)
    [k6] = "地址电话：" & ar(x, 6)
    If sl <= 38 Then
        m = 7
        For i = 0 To UBound(br)
            xh = br(i)
            If ar(xh, 1) <> "" Then
                m = m + 1
                For j = 7 To 14
                    lh = rr(j - 7)
                    Cells(m, lh) = ar(xh, j)
                Next j
            End If
        Next i
        If sl < 38 Then
            Rows(sl + 8 & ":45").EntireRow.Hidden = True
        End If
        [a1:n50].PrintOut
    ElseIf sl > 38 Then
        For i = 0 To UBound(br) Step 38
            [a8:n45].ClearContents
            [a8:n45].EntireRow.Hidden = False
            m = 7
            For s = i To i + 37
                If s <= UBound(br) Then
                    xh = br(s)
                    If ar(xh, 1) <> "" Then
                        m = m + 1
                        For j = 7 To 14
                            lh = rr(j - 7)
                            Cells(m, lh) = ar(xh, j)
                        Next j
                    End If
                End If
            Next s
            If m < 38 Then
                Rows(m + 1 & ":45").EntireRow.Hidden = True
            End If
            [a1:n50].PrintOut
        Next i
    End If
Next k
Application.ScreenUpdating = True
MsgBox "打印完毕！"
End Sub

3190496160

套打格式.rar (65.08 KB, 下载次数: 31)

2024-3-7 10:45 上传

点击文件名下载附件