按明细自动打印出库单

anywhere99

求助大神，如何按明细自动打印出库单，详见附件文件，谢谢

3190496160

需求不明确：
1、根据 明细表中的哪一项或者哪几项来生成一张出库单？
2、根据单号？那同一个单号有多个给一个，多个日期
3、根据日期？那同一个日期又有多个供应商，

3190496160

Sub 出库单()
Application.ScreenUpdating = False
Dim ar As Variant, cr As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), brr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("签字")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs < 2 Then MsgBox "签字工作表为空！": End
    cr = .Range(.Cells(1, 1), .Cells(rs, 2))
End With
For i = 2 To UBound(cr)
     If cr(i, 1) <> "" Then
        dc(cr(i, 1)) = i
    End If
Next i
With Sheets("明细")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "明细工作表为空！": End
    ar = .Range(.Cells(1, 1), .Cells(r, 9))
End With
For i = 2 To UBound(ar)
    If ar(i, 1) <> "" And ar(i, 3) <> "" Then
        zd = Format(ar(i, 1), "yyyymmdd") & "|" & ar(i, 3)
        If d(zd) = "" Then
            d(zd) = i
        Else
            d(zd) = d(zd) & "|" & i
        End If
    End If
Next i
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Index > 3 Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To 7)
    rr = Split(d(k), "|")
    For i = 0 To UBound(rr)
        xh = rr(i)
        n = n + 1
        For j = 4 To UBound(ar, 2)
            br(n, j - 3) = ar(xh, j)
        Next j
    Next i
    Sheets("出库单").Copy after:=Sheets(Sheets.Count)
    Set sht = ActiveSheet
    With sht
        .Name = k
        .[a6].Resize(n, UBound(br, 2)) = br
        .Rows(n + 7 & ":78").Delete
        gys = Split(k, "|")(1)
        hh = dc(gys)
        Sheets("签字").Select
        For Each shp In Sheets("签字").Shapes
            If shp.Type = 13 Then
                w = shp.TopLeftCell.Row
                If w = hh Then
                    shp.Copy
                    .Select
                    .Cells(n + 7, 2).Select
                    ActiveSheet.Paste
                    Exit For
                End If
            End If
        Next shp
    End With
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

出库单根据明细自动打印.rar (52.25 KB, 下载次数: 51)

2024-2-23 09:28 上传

点击文件名下载附件

anywhere99

根据日期，生成每个供应商的不同的出库单

辛苦各位大神支持

半百

ykcbf1100

参与一下，附件供参考。。。

ykcbf1100

代码供参考，代码以附件为准。

1. Sub ykcbf()   '//2024.2.23
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set d1 = CreateObject("Scripting.Dictionary")
   
7.     Set Sh = Sheets("签字")
   
8.     b = [{4,5,6,7,8,2,9}]
   
9.     For Each sp In Sh.Shapes
   
10.         s = sp.TopLeftCell.Offset(0, -1).Value
    
11.         Set d1(s) = sp
    
12.     Next
    
13.     With Sheets("明细")
    
14.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
15.         arr = .[a1].Resize(r, 9)
    
16.     End With
    
17.     For i = 2 To UBound(arr)
    
18.         s = Format(arr(i, 1), "yyyy-m-d") & "|" & arr(i, 3)
    
19.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
20.         d(s)(i) = i
    
21.     Next
    
22.     For Each sht In Sheets
    
23.         If d.exists(sht.Name) Then sht.Delete
    
24.     Next
    
25.     On Error Resume Next
    
26.     For Each k In d.keys
    
27.         Sheets("出库单模板").Copy after:=Sheets(Sheets.Count)
    
28.         Set sht = Sheets(Sheets.Count)
    
29.         t = Split(k, "|")
    
30.         m = 5
    
31.         With sht
    
32.             .Name = k
    
33.             If d(k).Count > 4 Then
    
34.                 Call zcr(8, d(k).Count - 4)
    
35.             End If
    
36.             r = .UsedRange.Find("签名").Row
    
37.             .[a4] = "日期：" & t(0)
    
38.             .[f4] = t(1)
    
39.             For Each kk In d(k).keys
    
40.                 m = m + 1
    
41.                 For j = 1 To UBound(b)
    
42.                     .Cells(m, j) = arr(kk, b(j))
    
43.                 Next
    
44.             Next
    
45.             d1(.[f4].Value).Copy
    
46.             .Cells(r, 2).Select
    
47.             .Paste
    
48.             .[a5].Select
    
49.         End With
    
50.     Next
    
51.     Sheets("明细").Activate
    
52.     Set d = Nothing
    
53.     Application.ScreenUpdating = True
    
54.     MsgBox "OK！"
    
55. End Sub

复制代码

anywhere99

3190496160 发表于 2024-2-23 09:28

给力太赞了，谢谢解决大问题了
还能再增加一个功能，就是自动生成自动批量打印功能吗？

3190496160

anywhere99 发表于 2024-2-23 16:37
给力太赞了，谢谢解决大问题了
还能再增加一个功能，就是自动生成自动批量打印功能吗？:loveli ...

刚刚才发现，目前的代码其实还存在一点问题的，等有时间再改一下呗，
至于批量打印，既然已经生成了，手工也可以打印 的嘛