2次匹配后求出电话号码

xinlan6

2次匹配后求出电话号码

1、表1为待求电话号码的数据，以B列单位名称为关键字，从表2提取职务为“主任”的人员姓名，填写在 F列对应单元格内。
如果找不到关键字，就在K列对应单元格内填写“查找不到主任，请检查数据或手工查找”。
如果找到关键字，但是表2职务为I列“主任”的人员姓名对应的单元格为空的，就在K列对应单元格内填写“主任暂缺”。
2、以表1的单位名称和主任的姓名为关键字（同一单位内没有同名同姓的），从表3提取电话号码，填写在G列的对应单元格内。
如果找不到，就在L列对应单元格内填写“查找不到电话号码，请检查数据或手工查找”。
3、3个表格数据条数不一致（表1大约几百条需查找，表2大约几百条数据，表3大约1万多条数据），顺序也不一致。
4、3个表格数据均为模拟数据，其中表2、表3中，个别单元格有空。
5、模拟结果详见表1红色字体。
6、可否使用VBA一键获得结果，请大神帮帮忙，谢谢！

凌空一羽

Sub lkyy()
myr = Range("a10000").End(3).Row
ar = Range("a1:L" & myr)
ar2 = Sheet2.Range("a2").CurrentRegion
ar3 = Sheet3.Range("a2").CurrentRegion
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
For i = 3 To UBound(ar2)
    d2(ar2(i, 4)) = ar2(i, 9)
Next

For i = 3 To UBound(ar3)
    t = ar3(i, 8) & "|" & ar3(i, 3)
    d3(t) = ar3(i, 15)
Next

For i = 3 To UBound(ar)
    If d2.exists(ar(i, 2)) Then
        Cells(i, "F") = d2(ar(i, 2))
        If d2(ar(i, 2)) = "" Then Cells(i, "k") = "主任暂缺"
    Else
        Cells(i, "k") = "查找不到主任，请检查数据或手工查找"
        Cells(i, "L") = "找不到电话号码，请检查数据或手工查找"
    End If
    t = ar(i, 2) & "|" & Cells(i, "F").Value
    If d3.exists(t) Then
        Cells(i, "g") = d3(t)
        If d3(t) = "" Then Cells(i, "L") = "查找不到电话号码，请检查数据或手工查找"
    End If
Next
Set d2 = Nothing
Set d3 = Nothing
End Sub