两表引用，类似于函数中的万金油,求大佬帮忙看看

morpheus126

歪一个楼，函数解决，速度无法保证。。。

limonet

关键字：where in

阿哩木

morpheus126 发表于 2024-2-23 11:45
歪一个楼，函数解决，速度无法保证。。。

我的还是2013版本

morpheus126

阿哩木 发表于 2024-2-23 11:55
我的还是2013版本

其实有辅助列的话，低版本函数也能解决，只不过就是速度和简洁问题而已

ykcbf1100

参与一下，附件供参考。。。

ykcbf1100

代码以附件为准。

1. Sub ykcbf()   '//2024.2.23
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set ws = ThisWorkbook
   
6.     Set Sh = ws.Sheets("查找")
   
7.     With Sh
   
8.         arr = .[o1:v2].Value
   
9.         For Each k In arr
   
10.             If k <> Empty Then
    
11.                 s = CStr(k)
    
12.                 d(s) = ""
    
13.             End If
    
14.         Next
    
15.     End With
    
16.     With Sheets("明细表")
    
17.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
18.         c = .UsedRange.Columns.Count
    
19.         arr = .[a1].Resize(r, c)
    
20.     End With
    
21.     ReDim brr(1 To UBound(arr), 1 To 9)
    
22.     For i = 2 To UBound(arr)
    
23.         s = CStr(arr(i, 10))
    
24.         If d.exists(s) Then
    
25.             m = m + 1
    
26.             For j = 2 To c - 1
    
27.                 brr(m, j - 1) = arr(i, j)
    
28.             Next
    
29.         End If
    
30.     Next
    
31.     With Sh
    
32.         .[n5:v10000] = ""
    
33.         .Columns("V:V").NumberFormatLocal = "@"
    
34.         .[n5].Resize(m, 9) = brr
    
35.     End With
    
36.     Set d = Nothing
    
37.     Application.ScreenUpdating = True
    
38.     MsgBox "OK！"
    
39. End Sub
    

复制代码