根据生产领料明细批量生成领料单

2217918

根据工作簿中【生产领料明细表】，批量【生成领料单】，麻烦各位老师，帮忙下，谢谢！

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Dim rng As Range
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     With Worksheets("生产领料明细")
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         arr = .Range("a2:j" & r)
   
10.         For i = 1 To UBound(arr)
    
11.             If Not d.exists(arr(i, 3)) Then
    
12.                 Set d(arr(i, 3)) = CreateObject("scripting.dictionary")
    
13.             End If
    
14.             d(arr(i, 3))(i) = Empty
    
15.         Next
    
16.     End With
    
17.     With Worksheets("生产领料单")
    
18.         .Cells.Clear
    
19.     End With
    
20.     r = 1
    
21.     With Worksheets("模板")
    
22.         For Each aa In d.keys
    
23.             r1 = .Cells(.Rows.Count, 2).End(xlUp).Row
    
24.             If r1 <> 5 Then
    
25.                 .Rows("5:" & r1 - 1).Delete
    
26.             End If
    
27.             ReDim brr(1 To d(aa).Count, 1 To 8)
    
28.             m = 0
    
29.             i = d(aa).keys()(0)
    
30.             For Each bb In d(aa).keys
    
31.                 m = m + 1
    
32.                 brr(m, 1) = m
    
33.                 For j = 2 To 8
    
34.                     brr(m, j) = arr(bb, j + 2)
    
35.                 Next
    
36.             Next
    
37.             .Range("d3") = arr(i, 2)
    
38.             .Range("f3") = Application.Sum(Application.Index(brr, 0, 7))
    
39.             .Range("h3") = aa
    
40.             .Rows(5).Resize(UBound(brr)).Insert
    
41.             With .Range("a5").Resize(UBound(brr), UBound(brr, 2))
    
42.                 .Value = brr
    
43.                 .Borders.LineStyle = xlContinuous
    
44.             End With
    
45.             r2 = 4 + UBound(brr) + 1
    
46.             .Range("a1:h" & r2).Copy Worksheets("生产领料单").Cells(r, 1)
    
47.             r = r + r2 + 1
    
48.         Next
    
49.     End With
    
50.                
    
51. End Sub
    

复制代码

chxw68

参与一下。

2217918

chxw68 发表于 2024-6-23 09:00
参与一下。

收到，非常感谢，谢谢老师！能否优化代码，提升运行速度，1个月的数据比较多?

chxw68

2217918 发表于 2024-6-23 09:07
收到，非常感谢，谢谢老师！能否优化代码，提升运行速度，1个月的数据比较多?

那我就不会了。

dambcer

2217918 发表于 2024-6-23 09:07
收到，非常感谢，谢谢老师！能否优化代码，提升运行速度，1个月的数据比较多?

还要多快啊，真是不值得被帮助

2217918

chxw68 发表于 2024-6-23 09:22
那我就不会了。

好的，收到，谢谢，非常感谢！

shiruiqiang

是写入excel表的速度问题吧。褚老师代码学习一下

准提部林

2217918 发表于 2024-6-23 09:07
收到，非常感谢，谢谢老师！能否优化代码，提升运行速度，1个月的数据比较多?

用了特殊設置//可能快一些
Xl0000252.rar (17.04 KB, 下载次数: 36)

2024-6-23 16:50 上传

点击文件名下载附件

2217918

准提部林 发表于 2024-6-23 16:52
用了特殊設置//可能快一些

收到，非常感谢！谢谢，谢谢！