[求助] 用VBA分类，并复制粘贴到另一个表中

灵魂兽

求助使用VBA将《装车表》中的数据按条件，自动复制并粘贴到《发货单》中，因数太多每次都要复制再粘贴，太浪费时间了。垦求老师帮助，指点指点，谢谢！

abc123281

可以实现   但工程也不小

灵魂兽

@abc123281  看到你回答我真的很开心，谢谢！
可以抽空帮我写一下代码吗，在此先谢过了，改天我请你吃饭哈。

abc123281

好啊  等待      会有结果的  

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   Application.ScreenUpdating = False
   
7.   Application.DisplayAlerts = False
   
8.   With Worksheets("装车表")
   
9.     bt = .Range("a3:r4")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     arr = .Range("a6:t" & r)
    
12.     For i = 1 To UBound(arr)
    
13.       arr(i, 20) = "是"
    
14.     Next
    
15.     .Range("a6:t" & r) = arr
    
16.     For i = 1 To UBound(arr)
    
17.       If Not d.exists(arr(i, 17)) Then
    
18.         m = 1
    
19.         ReDim brr(1 To m)
    
20.       Else
    
21.         brr = d(arr(i, 17))
    
22.         m = UBound(brr) + 1
    
23.         ReDim Preserve brr(1 To m)
    
24.       End If
    
25.       brr(m) = i
    
26.       d(arr(i, 17)) = brr
    
27.     Next
    
28.   End With
    
29.   With Worksheets("发货单")
    
30.     .Range("b3") = bt(1, 5)
    
31.     .Range("b4") = bt(1, 15)
    
32.     .Range("e4") = bt(1, 18)
    
33.     .Range("l4") = bt(2, 5)
    
34.     .Range("a23:o" & .Rows.Count).Delete shift:=xlUp
    
35.     k = 1
    
36.     For Each aa In d.keys
    
37.       brr = d(aa)
    
38.       m = 6
    
39.       .Range("e3,l3,b6:n17") = ""
    
40.       .Range("e3") = aa
    
41.       .Range("l3") = arr(brr(1), 18)
    
42.       For i = 1 To UBound(brr)
    
43.         For j = 2 To 13
    
44.           .Cells(m, j) = arr(brr(i), j)
    
45.         Next
    
46.         m = m + 1
    
47.         If m > 17 Or i = UBound(brr) Then
    
48.           k = k + 23
    
49.           .Range("a1:o22").Copy .Cells(k, 1)
    
50.           m = 6
    
51.           .Range("b6:n17") = ""
    
52.         End If
    
53.       Next
    
54.     Next
    
55.     .Range("a1:o23").Delete shift:=xlUp
    
56.   End With
    
57.   Application.ScreenUpdating = True
    
58.   MsgBox "发货单生成完毕！"
    
59. End Sub
    

复制代码

chxw68

请abc123281坛友斧正。

abc123281

我先下载学习了

chxw68

纠正了其中存在的问题。

abc123281

非常完美   没问题了

abc123281

等待楼主的判断