如何用VBA找寻数千条记录？

maikoyuki

TenderInventoryVVV.rar (23.18 KB, 下载次数: 6)

2023-4-18 22:21 上传

点击文件名下载附件

感激各位赐教！

gwjkkkkk

请参考。。。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set d1 = CreateObject("scripting.dictionary")
   
7.     With Worksheets("sheet1")
   
8.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
9.         arr = .Range("a2:e" & r)
   
10.     End With
    
11.     n = 2
    
12.     For i = 1 To UBound(arr)
    
13.         If Not d1.exists(arr(i, 3)) Then
    
14.             n = n + 1
    
15.             d1(arr(i, 3)) = n
    
16.         End If
    
17.     Next
    
18.     ls = 2 + d1.Count
    
19.     For i = 1 To UBound(arr)
    
20.         xm = arr(i, 4) & "+" & arr(i, 1)
    
21.         If Not d.exists(xm) Then
    
22.             ReDim brr(1 To ls)
    
23.             brr(1) = arr(i, 4)
    
24.             brr(2) = arr(i, 1)
    
25.         Else
    
26.             brr = d(xm)
    
27.         End If
    
28.         n = d1(arr(i, 3))
    
29.         If brr(n) = Empty Then
    
30.             brr(n) = i
    
31.         Else
    
32.             If arr(brr(n), 5) < arr(i, 5) Then
    
33.                 n = i
    
34.             End If
    
35.         End If
    
36.         d(xm) = brr
    
37.     Next
    
38.     ReDim crr(1 To d.Count, 1 To ls)
    
39.     m = 0
    
40.     For Each aa In d.keys
    
41.         brr = d(aa)
    
42.         For j = 3 To UBound(brr)
    
43.             If brr(j) <> Empty Then
    
44.                 brr(j) = arr(brr(j), 2)
    
45.             End If
    
46.         Next
    
47.         m = m + 1
    
48.         For j = 1 To UBound(brr)
    
49.             crr(m, j) = brr(j)
    
50.         Next
    
51.     Next
    
52.     With Worksheets("sheet2")
    
53.         .Cells.Clear
    
54.         .Range("a1:b1") = Array("Group2", "LocnID")
    
55.         For j = 1 To 2
    
56.             .Cells(1, j).Resize(2, 1).Merge
    
57.         Next
    
58.         With .Range("c1").Resize(1, d1.Count)
    
59.             .Merge
    
60.             .Value = "TenderID"
    
61.         End With
    
62.         .Range("c2").Resize(1, d1.Count) = d1.keys
    
63.         .Range("a3").Resize(UBound(crr), UBound(crr, 2)) = crr
    
64.         With .Range("a1").Resize(2 + UBound(crr), ls)
    
65.             .Borders.LineStyle = xlContinuous
    
66.             With .Font
    
67.                 .Name = "微软雅黑"
    
68.                 .Size = 10
    
69.             End With
    
70.             .HorizontalAlignment = xlCenter
    
71.             .VerticalAlignment = xlCenter
    
72.         End With
    
73.             
    
74.     End With
    
75. End Sub
    

复制代码

chxw68

参与一下。

maikoyuki

gwjkkkkk 发表于 2023-4-18 22:45
请参考。。。

谢谢提供参考，就是TenderID那列没有排序。

maikoyuki

chxw68 发表于 2023-4-19 08:29
参与一下。

谢谢提供参考，就是TenderID那列没有排序。

边缘码农

这个问题，我感觉，用函数也可以。

chxw68

maikoyuki 发表于 2023-4-26 12:59
谢谢提供参考，就是TenderID那列没有排序。

楼主哪个贴子里说排序了?另外这列怎么排序呢?

grf1973

相当漂亮。

边缘码农

chxw68 发表于 2023-4-26 14:22
楼主哪个贴子里说排序了?另外这列怎么排序呢?

楼主的帖子里没说排序的事，附件中sheet2这个表的c2:p2单元格的数据是有顺序的。