求大神帮忙修改下送货单代码，万分感谢

xintianhuahui

在论坛里下载大神写的送货单表，非常好用，但是原先是把每个客户送货单生成一个个工作表，这样打印没哪么方便，请大神帮忙修改为把发货单全部生成在一张工作表内，方便一次性全部打印出来，谢谢

ykcbf1100

这看上去是chxw68老师写的代码。

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")
With Worksheets("订单明细")
  r = .Cells(.Rows.Count, 1).End(xlUp).Row
  ar = .Range("a2:t" & r)
End With
For i = 2 To UBound(ar)
    If ar(i, 4) <> "" Then
        If Not d.Exists(ar(i, 4)) Then Set d(ar(i, 4)) = CreateObject("scripting.dictionary")
         d(ar(i, 4))(i) = ""
    End If
Next i
With Sheets("发货单")
    rs = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Rows("1:" & rs).Delete
    For Each k In d.Keys
        n = 0: hj = 0
        ReDim br(1 To UBound(ar), 1 To 5)
        For Each kk In d(k).Keys
            If ar(kk, 1) <> "" Then
                n = n + 1
                For j = 6 To 9
                    br(n, j - 5) = ar(kk, j)
                Next j
                br(n, 5) = ar(kk, 11)
                rq = ar(kk, 1)
                kh = ar(kk, 2)
                mc = ar(kk, 3)
                md = ar(kk, 5)
                dz = ar(kk, 20)
                sh = ar(kk, 10)
                hj = hj + ar(kk, 9)
            End If
        Next kk
        ws = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
        If ws = 3 Then
            ws = 1
        Else
            ws = ws
        End If
        Sheets("模板").Rows("1:6").Copy .Cells(ws, 1)
        .Cells(ws + 1, 2) = rq
        .Cells(ws + 1, 4) = k
        .Cells(ws + 2, 2) = kh
        .Cells(ws + 2, 4) = mc
        .Cells(ws + 3, 2) = md
        .Cells(ws + 3, 4) = sh
        .Cells(ws + 4, 2) = dz
        .Cells(ws + 6, 1).Resize(n, UBound(br, 2)) = br
        .Cells(ws + 6, 1).Resize(n, UBound(br, 2)).Borders.LineStyle = 1
        Sheets("模板").Rows("18:20").Copy .Cells(ws + n + 6, 1)
        .Cells(ws + n + 6, 4) = hj
    Next k
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

送货单.rar (27.89 KB, 下载次数: 16)

2024-9-12 09:29 上传

点击文件名下载附件

3190496160

结果未认真核对，实在不行，可以加v

ykcbf1100

参与一下。。。

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.12
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     With Sheets("订单明细")
   
7.         r = .Cells(Rows.Count, 1).End(3).Row
   
8.         arr = .[a1].Resize(r, 20)
   
9.     End With
   
10.     For i = 2 To UBound(arr)
    
11.         s = CStr(arr(i, 4))
    
12.         If Not d1.Exists(s) Then
    
13.             d1(s) = Array(arr(i, 1), arr(i, 4), arr(i, 2), arr(i, 3), arr(i, 5), arr(i, 10), arr(i, 20))
    
14.         End If
    
15.         If Not d.Exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
16.         d(s)(i) = ""
    
17.     Next
    
18.     With Sheets("发货单")
    
19.         .Cells.Clear
    
20.         For Each k In d.Keys
    
21.             n = n + 1
    
22.             m = 0
    
23.             ReDim brr(1 To d(k).Count, 1 To 5)
    
24.             If n = 1 Then
    
25.                 r = 1
    
26.                 Sheets("模板").Cells.Copy .Cells(r, 1)
    
27.             Else
    
28.                 r = .Cells(Rows.Count, 1).End(3).Row + 2
    
29.                 Sheets("模板").Rows("1:17").Copy .Cells(r, 1)
    
30.             End If
    
31.             For Each kk In d(k).Keys
    
32.                 m = m + 1
    
33.                 brr(m, 1) = arr(kk, 6)
    
34.                 brr(m, 2) = arr(kk, 7)
    
35.                 brr(m, 3) = arr(kk, 8)
    
36.                 brr(m, 4) = arr(kk, 9)
    
37.                 brr(m, 5) = arr(kk, 11)
    
38.             Next
    
39.             If m > 7 Then
    
40.                 For i = 1 To m - 7
    
41.                     .Cells(r + 6 + i, 1).EntireRow.Insert
    
42.                 Next i
    
43.             End If
    
44.             .Cells(r + 6, 1).Resize(m, 5) = brr
    
45.             .Cells(r + 1, 2) = d1(k)(0): .Cells(r + 1, "d") = d1(k)(1)
    
46.             .Cells(r + 2, 2) = d1(k)(2): .Cells(r + 2, "d") = d1(k)(3)
    
47.             .Cells(r + 3, 2) = d1(k)(4): .Cells(r + 3, "d") = d1(k)(5)
    
48.             .Cells(r + 4, 2) = d1(k)(6)
    
49.         Next
    
50.         .DrawingObjects.Delete
    
51.     End With
    
52.     Set d = Nothing
    
53.     Set d1 = Nothing
    
54.     Application.ScreenUpdating = True
    
55.     MsgBox "OK！"
    
56. End Sub
    

复制代码

chxw68

修改好了。

chxw68

ykcbf1100 发表于 2024-9-12 08:51
这看上去是chxw68老师写的代码。

呵呵，看起来我的代码特点很明显。

ykcbf1100

chxw68 发表于 2024-9-12 09:49
呵呵，看起来我的代码特点很明显。

是的啊，每个人都有自己的代码风格。