Excel-VBA超级VLOOKUP查询引用输入工具
Excel-VBA超级VLOOKUP查询引用输入工具
哆哆Excel
发布于 2022-10-31 15:30:40
发布于 2022-10-31 15:30:40
VLookup用起来好，当你的数多了，引用的时间也不少
所以设计一个，超级VLOOKUP查询引用输入工具
【功能】
1.多条件设定（因为姓名时有重名，身份证时有大小写，有时姓名与身份证对不上，所以最好的方法是：姓名+身份证）
2.多数据引用
（功能：先打开数据源文件，把姓名+身份证统一转化为大写，再以此为条件把要的数据存入字典，再打开输入文件，查询，如果存在字典中，就批量引用数据）
【代码】
Sub yhd超级查询引用()
Dim s_rng As Range, a_rng As Range, b_rng As Range, condition
Dim dic_out As Object
Set dic_out = CreateObject("scripting.dictionary")
With Sheets("超级查询引用")
'===取值“条件模式”
condition = .Range("C1").Value
If condition = "单条件" Then
Set s_rng = Union(.Range("B4:D4"), .Range("B8:D8"))
Call CheckBlank(s_rng)
If Len(Trim(.Range("D4"))) = 0 Or Len(Trim(.Range("D8"))) = 0 Then MsgBox "你选择了“单条件”模式，D4与D8必须填写": Exit Sub
Else
Set s_rng = Union(.Range("B4:E4"), .Range("B8:E8"))
Call CheckBlank(s_rng)
If Len(Trim(.Range("D4"))) = 0 Or Len(Trim(.Range("D8"))) = 0 Or Len(Trim(.Range("E4"))) = 0 Or Len(Trim(.Range("E8"))) = 0 Then MsgBox "你选择了“单条件”模式，D4与D8必须填写": Exit Sub
End If
Set a_rng = .Range("B4") '设置初取值
Set b_rng = .Range("B8")
'===数组情况：1=文件路径2=工作表名3=姓名4=身份证（后面可多可少）5=本期收入6=养老7=医疗8=失业9=公积金10=职业年金
arr = a_rng.Resize(1, [Iv4].End(xlToLeft).Column - a_rng.Column + 1)
brr = b_rng.Resize(1, [IV8].End(xlToLeft).Column - b_rng.Column + 1)
End With
Call disAppSet(False)
'=======打开数据源文件，把要“条件”存入key，把“数据”存入items,1=文件名2=工作表，3=标题行数，4-5=条件
Set wb_out = Workbooks.Open(brr(1, 1))
With wb_out.Sheets(brr(1, 2))
.Activate
endrow = .Cells.Find("*", , , , 1, 2).Row
For i = brr(1, 3) + 1 To endrow
If condition = "单条件" Then
'===如果是单条件，一个数据，如果是双条件就两个数据相加
dickey = .Cells(i, brr(1, 4)).Value
Else
dickey = .Cells(i, brr(1, 4)).Value & .Cells(i, brr(1, 5)).Value
End If
If Len(Trim(UCase(dickey))) > 0 Then
dicitem = ""
For ii = 6 To UBound(brr, 2)
dicitem = dicitem & "@" & .Cells(i, brr(1, ii))
Next ii
dic_out(dickey) = dicitem
Else
End If
Next i
End With
wb_out.Close False
' =======存入字典完成，关闭数据源文件======
' =======打开输入文件，进行数据查询引用=====
Set wb_in = Workbooks.Open(arr(1, 1))
With wb_in.Sheets(arr(1, 2))
.Activate
endrow = .Cells.Find("*", , , , 1, 2).Row
For i = arr(1, 3) + 1 To endrow
If condition = "单条件" Then
'如果是单条件，一个数据，如果是双条件就两个数据相加
dickey = .Cells(i, arr(1, 4)).Value
Else
dickey = .Cells(i, arr(1, 4)).Value & .Cells(i, arr(1, 5)).Value
End If
If dic_out.exists(Trim(UCase(dickey))) Then
temp_arr = Split(dic_out(dickey), "@")
' MsgBox dic_out(s)
For jj = 1 To UBound(temp_arr)
ajj = jj + 5
.Cells(i, arr(1, ajj)) = temp_arr(jj)
Next jj
End If
Next i
.Cells(5, 1).Select
ActiveWindow.ScrollRow = 2
' 激活窗体，选中a5单元格，滚到到第二行，方便查看，再自己按保存
End With
' wb_in.Close SaveChanges:=True
Call disAppSet(True)
MsgBox "完成，自己查看一下，再保存"
' =======查询引用完成，关闭输入文件======
End Sub
'========CheckBlank检测空值，如果有空就退出=========
'使用方法
' Dim r As Range
' Set r = Union(Range("M4:O4"), Range("M8:O8"))
' Call CheckBlank(r)
'=================
Sub CheckBlank(rng)
For Each r In rng
If Application.WorksheetFunction.CountBlank(r) Then
MsgBox "你在" & r.Address & "没有填写内容"
Exit Sub
End If
Next
End Sub
Sub disAppSet(flag As Boolean)
With Application
.ScreenUpdating = flag
.DisplayAlerts = flag
.AskToUpdateLinks = flag
If flag Then
.Calculation = xlCalculationAutomatic
Else
.Calculation = xlCalculationManual
End If
End With
End Sub【使用方法】
设置好初始数据--按【执行】就可以批量多条件引用 多数据
本文参与?腾讯云自媒体分享计划，分享自微信公众号。
原始发表：2021-11-01，如有侵权请联系?cloudcommunity@tencent.com 删除
评论
登录后参与评论
推荐阅读