求助，VBA如何实现VLOOKUP的功能见附件

numberwyh

求助，VBA如何实现VLOOKUP的功能见附件

chis3

Sub test()
    Dim arr, i As Integer, dic As Object, brr(): Set dic = CreateObject("scripting.dictionary")
    arr = Sheets(2).[a1].CurrentRegion
    For i = 2 To UBound(arr)
        If Not dic.exists(arr(i, 1)) Then
            dic(arr(i, 1)) = arr(i, 2)
        End If
    Next i
    Sheets(1).Activate: arr = [a1].CurrentRegion
    ReDim brr(1 To UBound(arr) - 1, 1 To 1)
    For i = 2 To UBound(arr)
        brr(i - 1, 1) = dic(arr(i, 1))
    Next i
    [c2].Resize(UBound(brr), 1) = brr
    Set dic = Nothing
End Sub

jiminyanyan

简单的字典就可以了。。。

凌空一羽

Sub lkyy()
ar = Sheet2.Range("a1").CurrentRegion
br = Range("a1").CurrentRegion
For i = 2 To UBound(ar)
    k = 0: n = 1
    For j = 2 To UBound(br)
        If br(j, 1) = ar(i, 1) Then br(j, 3) = ar(i, 2): k = j: Exit For
    Next
    If k = 0 Then
        n = n + 1
        Cells(n, "K") = ar(i, 1)
        Cells(n, "L") = ar(i, 2)
    End If
    If n Then Range("a1:b1").Copy [k1]
Next
Range("a1").CurrentRegion = br
End Sub

xiaoxia520

1. Sub test()
   
2. Dim i&, arr, sth1 As Worksheet, sth2 As Worksheet, l&, zd As Object, j&, name$, names(), nums()
   
3. Set zd = CreateObject("scripting.dictionary")
   
4. Set sth1 = Worksheets(1)
   
5. Set sth2 = Worksheets(2)
   
6. sth2.Activate
   
7. l = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
   
8. For i = 2 To l
   
9.     k = Cells(i, 1)
   
10.     zd.Add k, Cells(i, 2)
    
11. Next i
    
12. sth1.Activate
    
13. l = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    
14. For j = 2 To l
    
15.     name = Cells(j, 1)
    
16.     sth1.Cells(j, 3) = zd.Item(name)
    
17.     zd.Remove name
    
18. Next j
    
19. l = zd.Count - 1
    
20. names = zd.keys()
    
21. nums = zd.items()
    
22. Range("k1:l1") = Array("姓名", "办公费")
    
23. Range(Cells(2, "k"), Cells(2 + l, "k")) = WorksheetFunction.Transpose(names)
    
24. Range(Cells(2, "l"), Cells(2 + l, "l")) = WorksheetFunction.Transpose(nums)
    
25. End Sub
    
26. 新手上路

复制代码

numberwyh

chis3 发表于 2018-8-9 20:45
Sub test()
    Dim arr, i As Integer, dic As Object, brr(): Set dic = CreateObject("scripting.dicti ...

谢谢回复，我研究研究

numberwyh

chis3 发表于 2018-8-9 20:45
Sub test()
    Dim arr, i As Integer, dic As Object, brr(): Set dic = CreateObject("scripting.dicti ...

谢谢回复，需要研究研究学习学习

numberwyh

xiaoxia520 发表于 2018-8-9 21:24

感谢帮助，解决不少重复性工作，我得好好学习天天向上