请用VBA查找

夏日生花

请用VBA查找，谢谢！

yaofengda

1. Sub Test()
   
2. Dim Arr, Brr, D, i%
   
3. Arr = Range([A3], [A65536].End(3))
   
4. Brr = Range([L3], [N65536].End(3))
   
5. Set D = CreateObject("scripting.dictionary")
   
6. For i = 1 To UBound(Brr)
   
7.     D(Brr(i, 1)) = Brr(i, 3)
   
8. Next
   
9. For i = 1 To UBound(Arr)
   
10.     Arr(i, 1) = IIf(D(Arr(i, 1)) = Empty, Empty, D(Arr(i, 1)))
    
11. Next
    
12. [E3].Resize(i - 1, 1) = Arr
    
13. End Sub

复制代码

gwjkkkkk

E3=

1. =VLOOKUP(A3,$L$3:$N$27,3,)

复制代码

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, i&, j&
   
    Application.ScreenUpdating = False
   
    br = Range("L3", Cells(Rows.Count, "N").End(xlUp)).Value
    With [A2].CurrentRegion
        .Columns("E").Offset(1).Clear
        ar = .Value
        For i = 1 To UBound(br)
            For j = 2 To UBound(ar)
                If ar(j, 1) = br(i, 1) Then ar(j, 5) = br(i, 3)
            Next j
        Next i
        .Value = ar
    End With

    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

VBA法。。。

yanglinzi

1. Sub 查找()
   
2. Dim arr, brr, i, j, r, d
   
3. Set d = CreateObject("scripting.dictionary")
   
4. With Sheet1
   
5.     r = .Cells(Rows.Count, "l").End(xlUp).Row
   
6.     arr = .Range("l2:n" & r)
   
7. End With
   
8. For i = 2 To UBound(arr)
   
9.     sa = arr(i, 1)
   
10.     d(sa) = arr(i, 3)
    
11. Next
    
12. brr = Range("a2").CurrentRegion
    
13. For i = 2 To UBound(brr)
    
14.     sb = brr(i, 1)
    
15.     If d.exists(sb) Then
    
16.         brr(i, 5) = d(sb)
    
17.     End If
    
18. Next
    
19. Range("a2").CurrentRegion = brr
    
20. End Sub
    

复制代码

yanglinzi

请测试。。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.5.9
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("表一")
   
4.         r = .Cells(Rows.Count, "l").End(3).Row
   
5.         arr = [l1].Resize(r, 3)
   
6.         For i = 3 To UBound(arr)
   
7.             s = CStr(arr(i, 1))
   
8.             d(s) = arr(i, 3)
   
9.         Next
   
10.         r = .Cells(Rows.Count, "a").End(3).Row
    
11.         arr = [l1].Resize(r, 3)
    
12.         ReDim brr(1 To r, 1 To 1)
    
13.         For i = 3 To UBound(arr)
    
14.             m = m + 1
    
15.             s = CStr(arr(i, 1))
    
16.             If d.exists(s) Then
    
17.                 brr(m, 1) = d(s)
    
18.             End If
    
19.         Next
    
20.         .[e3].Resize(m, 1) = brr
    
21.     End With
    
22.     MsgBox "OK！"
    
23. End Sub
    

复制代码

Qs18

Sub test()
Dim dic As Object, arr, brr, crr, i
Set dic = CreateObject("scripting.dictionary")
arr = Sheet1.Range([a3], Cells(Rows.Count, "a").End(xlUp))
brr = Sheet1.Range([l3], Cells(Rows.Count, "n").End(xlUp))
ReDim crr(1 To UBound(arr), 1 To 1)
For i = LBound(brr) To UBound(brr)
    dic(brr(i, 1)) = brr(i, 3)
Next i
For j = 1 To UBound(arr)
    crr(j, 1) = dic(arr(j, 1))
Next j
Sheet1.Range("E3").Resize(UBound(crr), 1) = crr
MsgBox "处理完毕！"
End Sub