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