统计人专属！统计插件002→VBA一键模糊匹配多列数据（附代码）
接上一期，下面我为大家写一个模糊匹配多列数据的代码，它可以通过关键字、通配符、关键字加通配符等来实现你想要匹配的数据，也可以通过它生成辅助列方便筛选数据：
（1）模糊匹配示例1（关键字匹配）→图1是“匹配表”，图2是“匹配源”（关键字匹配），图3是匹配结果（可以支持多列，本次展示2列）：
（2）通配符匹配示例2（通配符匹配，必须是英文状态，?表示一个字符，*表示任意字符）→图4是“匹配表”，图5是“匹配源”（通配符匹配），图6是匹配结果（可以支持多列，本次展示2列）：
重点来了：
方法1：开发工具→查看代码→双击UserForm1→双击“同工作簿模糊匹配多列数据”；
方法2：在打开的工作表（工作表不能只读，不然保存不了，可以新打开一个或新建一个）→Alt+F11→→双击“同工作簿模糊匹配多列数据”。
方法1和方法2一样的效果，
复制以下代码，粘贴在“同工作簿模糊匹配多列数据”按钮下，运行方法参照昨天的帖子。
----------------↓---------------------------------------代码开始
Dim shn, h&, lie&, lie1&, sr&, brr(), lsr(), i&, j&, k As String, w As Range, dw&, zdl&, a As String, crr, s&
Dim dh As Long '定标题包含行数
On Error GoTo tz
dh = InputBox("请输入标题底行:", "直接输入标题底行", 1)
If dh < 1 Then
MsgBox "请输入标题底行，必须是≥1的整数！"
Exit Sub
End If
If TextBox1.Text = "" Then
MsgBox "被匹配的工作表不能为空！"
GoTo tz
ElseIf TextBox2.Text = "" Then
MsgBox "要匹配的字段不能为空！"
GoTo tz
ElseIf TextBox3.Text = "" Then
MsgBox "被匹配的工作表不能为空！"
GoTo tz
End If
Application.ScreenUpdating = False '屏幕更新关闭
shn = TextBox3.Text
Sheets(TextBox1.Text).Select
If Cells(1, 1) = "" Then
MsgBox "被匹配的表中，A1单元格或整表没数据！"
GoTo tz
End If
lie1 = Cells(1, Columns.Count).End(xlToLeft).Column
On Error GoTo tz
If lie1 > 20 Then
lie1 = 20
End If
sr = InputBox("请输入要匹配的总列数（至少为1）:", "默认为匹配表的默认列数", lie1)
If sr < 1 Then
MsgBox "请输入要匹配的列数（≥1）！"
GoTo tz
End If
lsr() = Range("A1").CurrentRegion
Sheets(shn).Select
Application.ScreenUpdating = True '屏幕更新恢复（原注释有误，此处修正）
If ActiveSheet.AutoFilterMode Then ActiveSheet.Cells.AutoFilter
If TextBox2.Text <> "" Then
Set w = Rows("1:" & dh).Find(TextBox2.Text, LookIn:=xlValues, LookAt:=1)
If Not w Is Nothing Then
dw = Rows("1:" & dh).Find(What:=TextBox2.Text, LookAt:=1).Column
Else
MsgBox "中间表不存在要匹配的字段！→" & TextBox2.Text
GoTo tz
End If
Else
MsgBox "要匹配的字段不能为空！"
GoTo tz
End If
Set dic1 = CreateObject("scripting.dictionary") '定义字典
'--- 构建字典，修复原代码拼接错误 ---
Dim xxx As String, tempStr As String
For i = 1 To UBound(lsr)
xxx = Trim(lsr(i, 1)) '关键字段
If Not dic1.exists(xxx) Then
tempStr = lsr(i, 1) '第一列
For j = 2 To sr
tempStr = tempStr & "__" & lsr(i, j) '拼接后续列
Next j
dic1(xxx) = tempStr
End If
Next i
'--- 获取中间表关键列的最大行 ---
Dim l&, lrr(1 To 50) '↙最大列
For i = 1 To UBound(lrr)
lrr(i) = Cells(i, Columns.Count).End(xlToLeft).Column '找到整表的总列数
Next
zdl = Application.Max(lrr) '↖最大列
a = Split(Rows("1:" & dh).Find(What:=TextBox2.Text, LookAt:=1).Address, "$")(1) '找到字段列字母
pd = ActiveSheet.UsedRange.Rows.Count
If pd > 65536 Then
h = Range(a & "1000000").End(xlUp).Row
Else
h = Range(a & "65536").End(xlUp).Row
End If
'--- 根据 sr 确定输出列数 ---
Dim colCount As Long
colCount = IIf(sr = 1, 1, sr - 1)
ReDim brr(1 To h, 1 To colCount)
'--- 填充数据到 brr ---
For i = 1 To h
k = Trim(Cells(i, dw).Value)
If dic1.exists(k) Then
' 根据 sr 判断直接返回 key 还是分割后返回
If sr = 1 Then
brr(i, 1) = dic1(k) ' 直接返回 key 本身
Else
crr = Split(dic1(k), "__")
For j = 1 To UBound(crr)
brr(i, j) = crr(j)
Next
End If
Else
For Each ks In dic1.Keys() '否则用arr(i, kd)去查找每个字典,看是否有相似的
If Cells(i, dw) Like "*" & ks & "*" Then
If sr = 1 Then
brr(i, 1) = dic1(ks) ' 直接返回 key 本身
Else
crr = Split(dic1(ks), "__")
For j = 1 To UBound(crr)
brr(i, j) = crr(j)
Next j
End If
Exit For
End If
Next
End If
Next
'--- 写入表头 ---
If sr = 1 Then
Cells(1, zdl + 1).Value = TextBox2.Text & "_匹配值"
Else
' 可自定义表头，此处简单命名为“匹配列1”、“匹配列2”……
For j = 1 To sr - 1
Cells(1, zdl + j).Value = "匹配列" & j
Next j
End If
'--- 写入数据区域 ---
If h >= 2 Then
Range(Cells(1, zdl + 1), Cells(1, zdl + colCount)).Value = brr
End If
'--- 设置列格式（原代码保留）---
For s = zdl + 1 To zdl + colCount
If Cells(1, s) Like "*号*" Or Cells(1, s) Like "*码*" Or Cells(1, s) Like "*客户证件*" Then
Columns(s).NumberFormatLocal = "@"
ElseIf Cells(1, s) Like "*日期*" Or Cells(1, s) Like "*时间*" Then
Columns(s).NumberFormatLocal = "yyyy/m/d"
End If
Next s
Range(Cells(1, zdl + 1), Cells(h, zdl + colCount)).Value = brr
With Range(Cells(1, zdl + 1), Cells(1, zdl + colCount)).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Cells(1, zdl + 1).Select
Erase crr
tz:
Erase lsr: Erase brr
Set dic1 = Nothing
Application.ScreenUpdating = True '确保屏幕更新恢复
----------------↑---------------------------------------代码结束
本次内容告一段落，欢迎留言交流，您的每一份点赞与支持，都是我坚持的最大鼓励。
这是 VBA 统计插件系列的第3期，教你搭建专属窗体基础框架，后续会持续更新更多进阶技巧、功能优化、实用拓展，手把手带大家把 VBA 统计插件打磨到极致！
下期解锁更多 VBA 统计干货，让你的统计工作更高效、更个性化！