VBA 刷新资料

On_fire

老师好,
截图中的右侧结果好像是A列去重了 ( 去了第6, 7行 )
应该是左边的结果才对 ( Data的老资料本有7行 )

yynrzwh

难道是我传错文件了？

1. Sub test2()
   
2. 
   
3. Set d = CreateObject("scripting.dictionary")
   
4. ar = Sheets("New").UsedRange
   
5. br = Sheets("Data").UsedRange
   
6. mc = 0
   
7. 
   
8. ReDim cr(1 To UBound(ar) + UBound(br), 1 To UBound(ar, 2) + UBound(br, 2))
   
9.     For i = 1 To UBound(br)
   
10.         s = br(i, 1)
    
11.         If Not d.exists(s) Then
    
12.             Set d(s) = CreateObject("scripting.dictionary")
    
13.         End If
    
14.         If Not d(s).exists(i) Then
    
15.             Set d(s)(i) = CreateObject("scripting.dictionary")
    
16.         End If
    
17.                
    
18.         For j = 2 To UBound(br, 2)
    
19.             If br(i, j) <> "" Then
    
20.                 d(s)(i)(br(i, j)) = ""
    
21.             End If
    
22.         Next
    
23.     Next
    
24. 
    
25. lr = UBound(br)
    
26.     For i = 1 To UBound(ar)
    
27.         s = ar(i, 1)
    
28.         If d.exists(s) Then
    
29.             For Each k In d(s).keys
    
30.                 For j = 2 To UBound(ar, 2)
    
31.                     If ar(i, j) <> "" Then
    
32.                         d(s)(k)(ar(i, j)) = ""
    
33.                     End If
    
34.                 Next
    
35.             Next
    
36.         Else
    
37.             lr = lr + 1
    
38.             Set d(s) = CreateObject("scripting.dictionary")
    
39.             Set d(s)(lr) = CreateObject("scripting.dictionary")
    
40.             For j = 2 To UBound(ar, 2)
    
41.                 If ar(i, j) <> "" Then
    
42.                     d(s)(lr)(ar(i, j)) = ""
    
43.                 End If
    
44.             Next
    
45.         End If
    
46.     Next
    
47.    
    
48.     For Each k In d.keys
    
49.         For Each kk In d(k).keys
    
50.             cr(kk, 1) = k
    
51.             j = 1
    
52.             For Each kkk In d(k)(kk).keys
    
53.                 j = j + 1
    
54.                 cr(kk, j) = kkk
    
55.             Next
    
56.             If j > mc Then mc = j
    
57.         Next
    
58.     Next
    
59.    
    
60. With Sheets("Update")
    
61.     .UsedRange.Offset(, 6).Clear
    
62.     .Range("g1").Resize(lr, mc) = cr
    
63.     .Range("g1").Resize(lr, mc).HorizontalAlignment = xlCenter
    
64.     .Cells(UBound(br), "g").Resize(1, mc).Borders(xlEdgeBottom).LineStyle = xlDouble
    
65. End With
    
66. 
    
67. Set d = Nothing
    
68. End Sub
    

复制代码

yynrzwh

yynrzwh

On_fire

yynrzwh 发表于 2024-3-26 16:07

厉害…非常感谢!!!