求助老师帮忙看看如何提取数据

A刘志勇

在老师的基础上，小改了一下，请参考

ykcbf1100

风洞小木鱼 发表于 2024-2-27 16:37
老师，代码怎么修改 能给点建议吗

附件供参考。。。

ykcbf1100

代码如下：

1. Sub ykcbf()    '//2024.2.27
   
2.     Dim arr, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     With Sheet1
   
5.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
6.         arr = .[a1].Resize(r, 4)
   
7.     End With
   
8.     For i = 2 To UBound(arr)
   
9.         s = arr(i, 1)
   
10.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
11.         d(s)(i) = i
    
12.     Next
    
13.     With Sheets("查询")
    
14.         .[a7:f100] = ""
    
15.         dm = .[b3]
    
16.         For Each k In d.keys
    
17.             If k = dm Then
    
18.                 m = 6
    
19.                 For Each kk In d(k).keys
    
20.                     .[b4] = arr(kk, 2)
    
21.                     m = m + 1
    
22.                     .Cells(m, 1) = arr(kk, 3)
    
23.                     .Cells(m, 6) = arr(kk, 4)
    
24.                 Next
    
25.             End If
    
26.         Next
    
27.     End With
    
28.     Set d = Nothing
    
29.     MsgBox "OK！"
    
30. End Sub
    

复制代码

风洞小木鱼

万分感谢老师