订单打印生成代码

陈11点

这一张为数据源，为列表形式的，能一键生成为可以打印A4的订单模样，表2和表3为最终格式，可参照图2，

lizhipei78

非常简单的题目，字典嵌套一层就能解决

订单生成2024.2.14.rar (22.43 KB, 下载次数: 24)

2024-2-14 20:33 上传

点击文件名下载附件

lizhipei78

gwjkkkkk

Option Explicit

Sub TEST1()
    Dim ar, br, cr, dr, i&, j&, dic As Object, vKey, wks As Worksheet
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    ReDim dr(1 To 3, 0)
    ar = [B3].CurrentRegion
    For i = 2 To UBound(ar)
        dic(ar(i, 3)) = dic(ar(i, 3)) & " " & i
    Next i
   
    Set wks = Worksheets("模板")
    With Workbooks.Add
        For Each vKey In dic.keys
            cr = Split(dic(vKey))
            ReDim br(1 To UBound(cr), 1 To 3)
            For i = 1 To UBound(cr)
                br(i, 1) = i
                br(i, 2) = ar(cr(i), 1)
                br(i, 3) = ar(cr(i), 4)
            Next i
            dr(1, 0) = ar(cr(1), 3)
            dr(2, 0) = ar(cr(1), 5)
            dr(3, 0) = ar(cr(1), 6)
            wks.Copy after:=.Sheets(.Sheets.Count)
            With ActiveSheet
                .Name = dr(1, 0)
                .Cells(2, 3).Resize(3) = dr
                .Cells(7, 2).Resize(UBound(br), 3) = br
                With .Cells(6, 2).CurrentRegion
                    .Borders.LineStyle = xlContinuous
                    .EntireColumn.AutoFit
                End With
            End With
        Next
        For Each wks In .Worksheets
            If wks.Name Like "*Sheet*" Then wks.Delete
        Next
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。