VBA各种查询方法介绍和应用举例

ivccav

查询（或匹配）是程序设计中最重要的功能之一，只有用好查询功能，才能从纷繁复杂的数据中找到符合要求的数据子集，提高工作效率。查询分为模糊查询和精确查询，只匹配一个字符串中的部分字符串就是模糊查询，完全一致则是精确批量，例如字符串“excelhome”，用包含“excel”的条件进行查询是模糊查询，用等于“excelhome” 的条件进行查询则是精确查询。查询的方法多种多样，本贴总结了10种VBA查询方法，分享给大家，以博大方之家一笑，或者给初学者提供一点入门知识，不敢说什么抛砖引玉，因为我不是抛转的专家，不求引玉，只要不引来石头就够了。

1、Range对象的Find方法

Find方法跟在工作表中按Ctrl+F查询的效果一致，如果找到匹配单元格，该方法返回一个Range对象，没找到则返回Nothing。语法为：
表达式.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)
表达式是一个代表 Range 对象的变量。参数说明如下：


常用的参数为What和LookAt，我们举例说明。我们要在a2:a1550单元格中查找包含“132”的单元格（模糊查询），并把字符颜色改为红色，代码如下：


Sub 查询1()
    Dim c As Range, firstAddress$
    With Worksheets("数据库").Range("a2:a1550")
        Set c = .Find("132", lookat:=xlPart) '查找132,xlPart模糊查询,xlWhole精确查询
        If Not c Is Nothing Then
            firstAddress = c.Address’记录第一符合条件的地址
            Do
                c.Font.Color = vbRed
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress'退出条件
        End If
    End With
End Sub

注意的是，我们没有指定After参数，程序从区域的左上角的单元格之后开始查询，即A3开始查询，并在程序最后返回到A2，才对A2单元格进行查找。这里FindNext是继续由 Find方法开始的搜索。查找匹配相同条件的下一个单元格，并返回表示该单元格的 Range 对象。
Find方法是直接在Range对象上操作，因此效率不高，在查询量很少的时候可以用。如果查询数量巨大，最好把数据放在数组中进行处理。

ivccav

2. Range对象的Filter方法

2.1 AutoFilte自动筛选

    AutoFilter就是筛选，可使用多个条件进行查询，可精确查询和模糊查询，并可使用通配符和比较运算符。通配符?表示 任何单一字符，* 零个或多个字符。语法：
表达式.AutoFilter(Field, Criteria1, Operator, Criteria2, VisibleDropDown)
表达式是一个Range对象。参数说明如下：



XlAutoFilterOperator可选值如下：



需要注意的是，如果忽略全部参数，此方法仅在指定区域切换自动筛选下拉箭头的显示，不执行筛选动作。Criteria1和Criteria2是每一列字段可用的两个筛选关键词，最多2个，可用XlAutoFilterOperator的值指定该2个关键词之间的关系。如果需要多个字段进行筛选，请按顺序依次使用该语句。
例如筛选“推荐业务1”字段中包含“和目1”、“推荐业务2”等于“"流量套餐2” 、“推荐业务3”等于“"放心用5”的数据并复制到其他工作表中：

Sub 查询2()
    Application.ScreenUpdating = False
    With Worksheets("数据库").Range("a1:d1550")
        .AutoFilter Field:=2, Criteria1:="*和目1*" '可使用通配符和比较运算符模糊查询
        .AutoFilter Field:=3, Criteria1:="流量套餐2"’精确查询
        .AutoFilter Field:=4, Criteria1:="放心用5"
        '……可以继续增加更多条件
        Worksheets("结果集").UsedRange.ClearContents
        .Copy Worksheets("结果集").Range("a1")
        .AutoFilter '取消自动筛选
    End With
    Application.ScreenUpdating = True
End Sub

==========================
代码均以下图数据集进行编写:




补上本帖电子文档附件和源代码：

电子文档PDF.zip (566.56 KB, 下载次数: 1098)

2018-12-8 14:41 上传

点击文件名下载附件

程序源代码.zip (122.63 KB, 下载次数: 1831)

2018-12-8 14:41 上传

点击文件名下载附件

ivccav

2.2 AdvancedFilter高级筛选

    AdvancedFilter方法基于条件区域从列表中筛选或复制数据。如果初始选定区域为单个单元格，则使用单元格的当前区域。语法：
表达式.AdvancedFilter(Action, CriteriaRange, CopyToRange, Unique)
表达式为一个代表Range 对象的变量。参数说明如下：



为实现2.1节相同的查询结果，CriteriaRange设置为：



代码如下：
    Sub 查询3()
    Application.ScreenUpdating = False
    Worksheets("结果集").UsedRange.ClearContents
    With Worksheets("数据库")
        .Range("a1:d1550").AdvancedFilter xlFilterCopy, .Range("h1:k2"), Worksheets("结果集").Range("a1"), False
    End With
    Application.ScreenUpdating = True
End Sub

唯一需要说明的是CriteriaRange参数。条件区域至少包含两行，第一行包含一个或多个列标题，是想要在数据区域中筛选的字段，第二行开始包含的是想要获取的数据，可使用通配符，如果要获取不同的数据，可分列多行（不同行的条件是“或”的关系，同行的条件是“与”的关系），例如“推荐业务3”想查询“放心用5”或“放心用6”，在下图的K3单元格中加上“放心用6”，CriteriaRange改为Range("h1:k3")即可。

ivccav

3.Instr函数

以上两个方法都是针对Range对象的，实际运用中，很多数据都不在工作表中，没有办法使用上述的方法。其实，就算数据在工作表中，因为上述方法是对对象进行操作，也会严重影响效率，而首先会把数据装进数组之中再行处理。这节介绍的Instr函数可以方便快捷的匹配数组中的数据。该函数返回指定一字符串在另一字符串中最先出现的位置。语法为：
InStr([start, ]string1, string2[, compare])，参数说明：



compare 参数可选值为：



注意：第一个参数和第四个参数可以省略，但如果指定了第四个参数，第一个参数也应指定。
为实现2.1节相同的查询结果，可用代码：

Sub 查询4()
    Dim arr, brr, i&, j&, k&
    Application.ScreenUpdating = False
    arr = Worksheets("数据库").Range("a1").CurrentRegion
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2)) '存放符合查询条件的结果，数组大小跟arr一致
    '也可用Redim Preserve根据需要扩大数组，但只能扩大最后一维，故需要转置数组，效率较低
    For i = 1 To UBound(arr, 2): brr(1, i) = arr(1, i): Next '存储原标题
    j = 2
    For i = 2 To UBound(arr) '查询条件，用Instr函数匹配字符串
        If InStr(arr(i, 2), "和目1") > 0 And arr(i, 3) = "流量套餐2" And arr(i, 4) = "放心用5" Then
            For k = 1 To UBound(arr, 2): brr(j, k) = arr(i, k): Next
            j = j + 1
        End If
    Next
    With Worksheets("结果集")
        .UsedRange.ClearContents
        .Range("a1").Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    End With
    Application.ScreenUpdating = True
End Sub

我们可以用InStr(arr(i, 2), "和目1")的方式查询数组元素arr(i, 2)中是否包含"和目1"（模糊查询），也可以用一个Instr函数同时精确查询多个关键词，例如要“推荐业务3”字段中有"放心用5"、"放心用8"或"放心用9"，用InStr(“放心用5/放心用8/放心用9”, arr(i, 4))即可，比用逻辑运算符（And，Or等）连接多个条件更方便：arr(i, 4)=“放心用5” Or arr(i, 4)=“放心用8” Or arr(i, 4)=“放心用9” 。Instr应用远不仅此，例如想搞个自定义排名，除了可用Application.AddCustomList外，还可以用如Instr(“张三/李四/王五”,姓名)的形式，求得姓名所在位置，然后按这些位置排序即可，可根据实际需求应用。另外，InStrRev函数跟Instr函数类似，也返回一个字符串在另一个字符串中出现的位置，但从字符串的末尾开始查询。

ivccav

4.Like运算符

Like运算符用来比较两个字符串，如果跟条件匹配，返回TRUE，否则返回FALSE。语法：
result = string Like pattern
Like运算符跟其他比较运算符的区别是模式匹配，其pattern参数可以用如下字符：



为实现2.1节相同的查询结果，可用代码：
Sub 查询5()
    Dim arr, brr, i&, j&, k&
    Application.ScreenUpdating = False
    arr = Worksheets("数据库").Range("a1").CurrentRegion
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    For i = 1 To UBound(arr, 2): brr(1, i) = arr(1, i): Next '存储原标题
    j = 2
    For i = 2 To UBound(arr) '查询条件，用Like运算符匹配字符串，可用通配符
        If arr(i, 2) Like "*和目1*" And arr(i, 3) = "流量套餐2" And arr(i, 4) = "放心用5" Then
            For k = 1 To UBound(arr, 2): brr(j, k) = arr(i, k): Next
            j = j + 1
        End If
    Next
    With Worksheets("结果集")
        .UsedRange.ClearContents
        .Range("a1").Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    End With
    Application.ScreenUpdating = True
End Sub

由上可见，使用Like运算符的代码跟使用Instr函数的代码几乎一致，但Like更灵活。假如我们做一个窗体查询界面，使用Instr函数也能实现查询，但用Like运算符的好处是在查询框中使用*和?运算符，也能使用字符集。例如我们想查询表格中第一列的手机号中包括5、7或9的号码，只需用arr(i, 1) Like "*[579]*"就行了，比Instr更简洁。
查询大量数据时，为了极大的提高效率，通常会先把数据放进数组中再进行匹配，故Instr和Like是最常用的查询方式，我们要多运用，熟练于心。

ivccav

5.SQL查询语句

SQL(结构化查询语言Structured Query Language)是一门ANSI的标准计算机语言，用来访问和操作数据库系统。SQL 语句用于取回和更新数据库中的数据。SQL 可与数据库程序协同工作，比如 MS Access、DB2、Informix、MS SQL Server、Oracle、Sybase 以及其他数据库系统。入门级的SQL语法可花2个小时就学会，可看http://www.w3school.com.cn/sql/sql_select.asp ，SQL语句配合ADO对象，能像操作数据库一样操作工作表，使得很多时候查询代码变得简单易懂，也易于修改。且SQL语句查询不用考虑工作表中列的变动（使用数组的话，如果某些列变动了位置，则需要修改代码），只需维护SQL语句即可。SQL语句操作数据库，也能实现复杂的汇总功能，如：http://club.excelhome.net/thread-1416073-1-1.html，因此花几个小时去学习还是很划算的。如果查询到是数据要进行超过SQL语法能力的操作，可以用GetRows方法先转成数组。

为实现2.1节相同的查询结果，可用代码：

Sub 查询6()
    Dim objcnn As Object, objrst As Object, i&, sql$
    Application.ScreenUpdating = False
    Set objcnn = CreateObject("adodb.connection")
    Set objrst = CreateObject("adodb.recordset")
    objcnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=Yes';Data Source=" & ThisWorkbook.FullName
    sql = "select * from [数据库$A1:D] where 推荐业务1 like '%和目1%' and 推荐业务2='流量套餐2' and 推荐业务3='放心用5'"
    objrst.Open sql, objcnn, 1, 3
    With Worksheets("结果集")
        .UsedRange.ClearContents
        For i = 0 To objrst.Fields.Count - 1 '输出标题
            .Cells(1, i + 1) = objrst.Fields(i).Name
        Next
        .Range("a2").CopyFromRecordset objrst '输出数据
    End With
    objrst.Close
    objcnn.Close
    Set objrst = Nothing
    Set obcnn = Nothing
    Application.ScreenUpdating = True
End Sub
注意：在SQL语句中需用%代替通配符*。

ivccav

6.ADO Recordset对象Find方法和Filter属性

如果只是查询并输出数据，使用上一节的SQL语句足够了，但是很多时候查询是为了修改特定的数据，且需要多

处修改，如果使用SQL UPDATE修改，会有诸多不便。首先各个数据库的SQL语法稍有差异；其次UPDATE语

句也更复杂；还有，使用SQL语句频繁访问数据库也是难以实现的，毕竟一台计算机只能同时服务几十个连接，

而使用ADO Recordset对象则可以把数据放在本地编辑，批量修改好之后再连接数据库更新修改。

6.1 Find方法

语法为：Rst.Find (Criteria, SkipRows, SearchDirection, Start)，Rst为Recordset数据集对象。
参数说明：




一般只用第一个参数和第二个参数。在 criteria 中只能指定单列名称，故不支持多列搜索，想要多列查询，

可用6.2节中的Filter属性。
Criteria 中的比较操作符可以是“>”（大于）、“<”（小于）、“=”（等于）、“>=”（大于或等于）、

“<=”（小于或等于）、“<>”（不等于）或“like”（模式匹配）。
Criteria 中的值可以是字符串、浮点数或者日期。字符串值用单引号或“#”标记（数字号）分隔（如“字段1

= '值1'”或“字段1 =#值1#”）。日期值用“#”标记（数字号）分隔（如“start_date > #7/22/97#”）并

可包括小时、分钟和秒以指示时间戳，但不能包括毫秒，否则将出现错误。
如果比较操作符为“like”，可以在字符串值中包含星号 (*) 以查找一次或多次出现的任意字符或子字符串。

星号可以只在条件字符串的结尾使用，也可以在条件字符串的开头和结尾一起使用，如上所示。不能将星号作

为前导通配符 ('*str') 或嵌入通配符 ('s*r') 使用。这将引发错误。

查询“推荐业务1”字段中包含“和目1”的代码为：

Sub 查询7()
    Dim objcnn As Object, objrst As Object, i&, sql$
    Application.ScreenUpdating = False
    Set objcnn = CreateObject("adodb.connection")
    Set objrst = CreateObject("adodb.recordset")
    objcnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=Yes';Data

Source=" & ThisWorkbook.FullName
    sql = "select * from [数据库$A1:D]"
    objrst.Open sql, objcnn, 1, 3
    With Worksheets("结果集")
        .UsedRange.ClearContents
        For i = 0 To objrst.Fields.Count - 1 '输出标题
            .Cells(1, i + 1) = objrst.Fields(i).Name
        Next
        j = 2
        objrst.MoveFirst '注意：数据集在查询后可能不在第一行，每次查询前移到第一行是稳妥行为
        '不指定开始行参数的情况下，Find会从当前行开始查询
        objrst.Find "推荐业务1 like '*和目1*'"
        Do While Not objrst.EOF
            For i = 0 To objrst.Fields.Count - 1 '输出数据
                .Cells(j, i + 1) = objrst.Fields(i)
            Next
            j = j + 1
            objrst.Find "推荐业务1 like '*和目1*'", 1
        Loop
    End With
    objrst.Close
    objcnn.Close
    Set objrst = Nothing
    Set obcnn = Nothing
    Application.ScreenUpdating = True
End Sub

ivccav

6.2 Filter属性

    用 Filter属性选择性地屏蔽Recordset对象中的记录。条件字符串由字段名-操作符-值格式（如“字段1 = '值1'”）子句组成。通过连接单独的 AND（如“字段1 = '值1'  AND字段2= '值2'”）或 OR（如“字段1 = '值1' OR 字段2= '值2'”）子句可以创建复合子句。对于条件字符串，请遵循以下规则：
字段名必须是Recordset对象中有效的字段名。如果字段名包含空格，必须将字段名括在方括号中。
操作符必须是下列字符串之一：<、>、<=、>=、<>、= 或 LIKE。
值是用于与字段值进行比较的值（如 '张三'、#8/24/95#、12.345）。字符串使用单引号，日期使用磅符号 (#)。数字可以使用小数点、美元符号和科学符号。如果操作符为LIKE，则值可以使用通配符，只允许使用星号 (*) 和百分号 (%) 通配符，可在模式的开头和结尾使用通配符，（如 字段 Like '*ab*'），或者只在模式的结尾使用通配符（如 字段 Like 'Tab*'）。
AND 和 OR 在级别上没有先后之分，可用括号将子句分组。但不能象下例所示那样先将由 OR 连接的子句分组，然后再用 AND 将该组连接到其他子句：
(字段1=‘值1’ OR字段1='值2') AND字段2='值3'，
与之相反，可将此过滤构造为：
(字段1=‘值1’ AND字段2='值3') OR (字段1='值2' AND字段2='值3')

为实现2.1节相同的查询结果，可用代码：
Sub 查询8()
    Dim objcnn As Object, objrst As Object, i&, sql$
    Application.ScreenUpdating = False
    Set objcnn = CreateObject("adodb.connection")
    Set objrst = CreateObject("adodb.recordset")
    objcnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=Yes';Data Source=" & ThisWorkbook.FullName
    sql = "select * from [数据库$A1:D]"
    objrst.Open sql, objcnn, 1, 3
    With Worksheets("结果集")
        .UsedRange.ClearContents
        For i = 0 To objrst.Fields.Count - 1 '输出标题
            .Cells(1, i + 1) = objrst.Fields(i).Name
        Next
        objrst.Filter = "推荐业务1 like '%和目1%' and 推荐业务2='流量套餐2' and 推荐业务3='放心用5'" '查询筛选
        If objrst.RecordCount Then '筛选后如果有符合条件的子集，则RecordCount>0
            .Range("a2").CopyFromRecordset objrst '输出数据
        End If
        objrst.Filter = "" '这条语句清空筛选条件
    End With
    objrst.Close
    objcnn.Close
    Set objrst = Nothing
    Set obcnn = Nothing
    Application.ScreenUpdating = True
End Sub

如果Recordset对象的Find方法无法满足需求，而你又不想使用Filter，那么，你可以像使用数组一样循环Recordset对象，使用前面介绍的Instr和Like方法查询。循环Recordset对象的代码如下：

Sub 查询9()
    Dim objcnn As Object, objrst As Object, i&, j&, sql$
    Application.ScreenUpdating = False
    Set objcnn = CreateObject("adodb.connection")
    Set objrst = CreateObject("adodb.recordset")
    objcnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=Yes';Data Source=" & ThisWorkbook.FullName
    sql = "select * from [数据库$A1:D]"
    objrst.Open sql, objcnn, 1, 3
    With Worksheets("结果集")
        .UsedRange.ClearContents
        For i = 0 To objrst.Fields.Count - 1 '输出标题
            .Cells(1, i + 1) = objrst.Fields(i).Name
        Next
        j = 2
        Do While Not objrst.EOF
            If objrst("推荐业务1") Like "*和目1*" And objrst("推荐业务2") = "流量套餐2" And objrst("推荐业务3") = "放心用5" Then
                For i = 0 To objrst.Fields.Count - 1 '输出数据
                    .Cells(j, i + 1) = objrst.Fields(i)
                Next
                j = j + 1
            End If
            objrst.MoveNext
        Loop
'==================================================================
'或者如下代码。注意：objrst(i)=objrst.Fields(i)，且字段下标是从0开始的。
'
'        Do While Not objrst.EOF
'            If objrst(1) Like "*和目1*" And objrst(2) = "流量套餐2" And objrst(3) = "放心用5" Then
'                For i = 0 To objrst.Fields.Count - 1 '输出数据
'                    .Cells(j, i + 1) = objrst(i)
'                Next
'                j = j + 1
'            End If
'            objrst.MoveNext
'        Loop
'
'==================================================================
    End With
    objrst.Close
    objcnn.Close
    Set objrst = Nothing
    Set obcnn = Nothing
    Application.ScreenUpdating = True
End Sub

如果你更想把Recordset对象转成真的数组以符合使用习惯，可以使用 GetRows 方法将 Recordset 中的记录复制到二维数组中。第一个下标标识字段，第二个下标标识记录编号，下标编号从0开始。GetRows获得的数组是倒过来的，需要转置一次才符合使用习惯，可以实现自定义转置函数，可以用工作表函数Application.WorksheetFunction.Transpose。需要注意的是，工作表转置函数Transpose只能处理65536行数据，且无法处理Null值。Recordset对象转成数组的完整代码如下：

Sub 转换1()
    Dim objcnn As Object, sql$, arr
    Application.ScreenUpdating = False
    Set objcnn = CreateObject("adodb.connection")
    objcnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=Yes';Data Source=" & ThisWorkbook.FullName
    sql = "select * from [数据库$A1:D]"
    arr = objcnn.Execute(sql, , 1).GetRows
    arr = transpose(arr) '转置，也可用:Application.WorksheetFunction.Transpose
    With Worksheets("结果集")
        .UsedRange.ClearContents
        .Range("a2").Resize(UBound(arr, 1) + 1, UBound(arr, 2) + 1) = arr
    End With
    objcnn.Close
    Set obcnn = Nothing
    Application.ScreenUpdating = True
End Sub

Function transpose(drr) '自定义转置函数
    Dim brr(), L1&, U1&, L2&, U2&
    L1 = LBound(drr): U1 = UBound(drr)
    L2 = LBound(drr, 2): U2 = UBound(drr, 2)
    ReDim brr(L2 To U2, L1 To U1)
    For i = L1 To U1
        For j = L2 To U2
            If IsNull(drr(i, j)) Then drr(i, j) = ""
            brr(j, i) = drr(i, j)
        Next
    Next
    transpose = brr
End Function

ivccav

7.正则表达式

    据说正则表达式（Regular Expression）源于神经生物科学家，想想也是挺神奇的事。正则表达式绝对是匹配字符串的王者，很复杂的查询条件，都能写在一个模式匹配里面。匹配某类字符串或某种字符串组织规则时，正则表达式尤为好用。通过给定一个正则表达式和另一个字符串，可以实现两个目的：
1. 给定的字符串是否符合正则表达式的模式串(pattern)，符合就叫匹配，不符合就不匹配；
2.通过正则表达式，可以从字符串中获取、修改和删除特定部分的字符串、增加特定字符串。
正则表达式由普通字符和元字符组成。普通字符包括大小写字母、数字、下划线或汉字等，而元字符是事先规定的符号，具有特殊的含义，了解了元字符的含义，正则表达式基本上就入门了。下面的元字符是我从网上复制的， VBA的正则表达式不支持其中的少量元字符，比如预查貌似就不支持，使用时加以区分即可。


一些例子：
1.电话号码：（"^(\d{3,4}-)\d{7,8}$"）格式：xxx/xxxx-xxxxxxx/xxxxxxxx；
2.手机号码："^1[3|4|5|7|8][0-9]{9}$"；

正则表达式对象只有Replace、Test和Execute三个方法，Pattern、Global、Ignorecase和Multiline四个属性和Matches集合，半个小时就能搞清楚个大概，本论坛有很多正则表达式的教程，这里不再赘叙。

为实现2.1节相同的查询结果，可用代码：
Sub 查询10()
    Dim arr, brr, i&, j&, k&, reg As Object
    Application.ScreenUpdating = False
    arr = Worksheets("数据库").Range("a1").CurrentRegion
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    For i = 1 To UBound(arr, 2): brr(1, i) = arr(1, i): Next '存储原标题
    j = 2
    Set reg = CreateObject("vbscript.regexp") '创建正则表达式对象
    reg.Pattern = "和目1" '匹配模式，正则表达式的核心所在，多练习才能掌握
    For i = 2 To UBound(arr) '查询条件，用正则表达式匹配
        If reg.test(arr(i, 2)) = True And arr(i, 3) = "流量套餐2" And arr(i, 4) = "放心用5" Then
            For k = 1 To UBound(arr, 2): brr(j, k) = arr(i, k): Next
            j = j + 1
        End If
    Next
    With Worksheets("结果集")
        .UsedRange.ClearContents
        .Range("a1").Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    End With
    Set reg = Nothing
    Application.ScreenUpdating = True
End Sub

这样看，貌似正则表达式也没什么特殊表现。我们假如要查询手机号最后一位数字是8，倒数第二、三位数字是3、6、9中的数字，用正则表达式就能体现优势了，只需要reg.Pattern = "[369]{2}8$"，对手机号码字段进行匹配即可：

Sub 查询11()
    Dim arr, brr, i&, j&, k&, reg As Object
    Application.ScreenUpdating = False
    arr = Worksheets("数据库").Range("a1").CurrentRegion
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    For i = 1 To UBound(arr, 2): brr(1, i) = arr(1, i): Next
    j = 2
    Set reg = CreateObject("vbscript.regexp")
    reg.Pattern = "[369]{2}8$"
    For i = 2 To UBound(arr)
        If reg.test(arr(i, 1)) Then
            For k = 1 To UBound(arr, 2): brr(j, k) = arr(i, k): Next
            j = j + 1
        End If
    Next
    With Worksheets("结果集")
        .UsedRange.ClearContents
        .Range("a1").Resize(UBound(brr, 1), UBound(brr, 2)) = brr
    End With
    Set reg = Nothing
    Application.ScreenUpdating = True
End Sub

ivccav

8.字典和哈希表

上述各种方法既能精确查询，也能模糊查询，已经足够使用。如果配合使用数组，几十万行的数据查询，速度也是相当快了。但有一个缺点，即每次查询都需要循环整个数据集，在某些情况下，比如多重循环，那循环计算量相当大。这是一个问题。如果有一种方法，给定一个查询关键字，一步就能定位到需要的数据位置，那就能节约很多时间。理论上是能一步到位的。如著名的MD5算法，碰撞概率是2^256分之一（碰撞就是给定不相同的两个字符串，散列函数映射出来的数字相同），因此只要定义一个足够大的数组，用该字符串的映射值作为数组下标位置存放该字符串在数组中，那么，只要给定查询关键词，就能计算出唯一的数字，用该数组作为数组下标，那么总能一步到位找到该位置存储的数据，而无需循环。
解决上述问题的是一种叫哈希表的数据结构，这种表中的每个元素都由键和数据两部分组成，以数组的形式存储。哈希表不使用键作为数组的下标（太浪费空间了），而是利用某种散列函数将关键词（键）转换（专业术语叫映射）为数组的下标，并用此下标的数组空间存储数据，这样建立的数组空间不会占用太多空余空间。详细内容可自行百度学习，也可看看《老兵新传 Visual Basic核心编程及通用模块开发》3.3节：哈希表，（P53，2012年8月第一版）。

8.1 字典

哈希表的特性是精确查询，而不适合模糊查询，因为不同的查询关键词映射出来的数字相差甚远，根本不可能给出明确的位置指向。据说字典也是这样一种散列函数的产物，假如给定一个完整的手机号码（精确查询），就能“一步到位”的找到需要的位置，而无需循环，而如果只给个手机尾号（模糊查询），就要循环整个字典了。字典是VBA对象，循环字典远不如循环数组速度快，模糊查询还是继续用数组吧。
字典可用于高效地多次精确查询数据（只查询一次的话，用字典也没有意义，因为需要循环数组把数据放进字典），或用于去重复。假如我们要从几十万个电话号码中查询客户资料，只要把这些客户资料或资料的位置存储在字典中，就能建立高效地查询系统。字典的教程，论坛中有很多精彩的帖子，这里不再赘叙，推荐蓝版一贴：http://club.excelhome.net/thread-868892-1-1.html，本帖只提供字典应用的一个简单代码：

Sub 查询12()
    Dim i&, k, arr, d As Object, reg As Object
    arr = Worksheets("数据库").Range("a1").CurrentRegion
    Set d = CreateObject("scripting.dictionary") '创建字典对象
    For i = 1 To UBound(arr) '把数据装载到字典。数据量巨大时，可只存储数据所在行号
        d(arr(i, 1)) = arr(i, 2) & "/" & arr(i, 3) & "/" & arr(i, 4)
    Next
    k = Application.InputBox("请输入查询的手机号码", Type:=1) '手机号是数字
    If k = False Then Exit Sub '输入框点击取消时返回False

    Set reg = CreateObject("vbscript.regexp")
'    reg.Pattern = "^(?:\+86)?1[34578]\d{9}$"
    reg.Pattern = "^1[34578]\d{9}$" '判断手机号码是否有误。非必要！只是复习一下正则。
    If reg.test(k) = False Then MsgBox "手机号码输入有误": Exit Sub

    If d.exists(k) Then
        MsgBox k & "用户 套餐：" & String(2, vbNewLine) & d(k)
    Else
         MsgBox "没有查询到数据"
    End If
    Set d = Nothing
    Set reg = Nothing
End Sub

8.2 哈希表

刚才已经介绍过了，散列函数，也译为"哈希"（Hash），就是把任意长度的输入，通过散列算法，映射成固定长度的输出。著名的散列算法有MD5、SHA1、CRC32等。字典也应该是散列函数的产物，因字典是商业产品，需要考虑经济性（占用更是资源）、易用性、稳定性，在速度上可能会有所折扣，在几十万行数据的情况下已经足够，但如果数据量更大时，则会显得稍微慢一些，于是在处理特殊情况时，有些朋友会利用散列函数的原理和算法，自定义自己的字典来处理，这样在速度上更上一层楼。自定义字典的关键是构造哈希函数和解决碰撞问题。散列函数的算法很复杂，但那是数学家的事，而自定义字典（或哈希表）则是简单的事，主要是利用数学家和计算机科学家的研究结论解决碰撞问题，往往几十句代码就能做出可用的哈希表。上边提到的书中有内容是介绍哈希表的原理的，可以先看看。论坛有不少自定义的字典帖，例如：http://club.excelhome.net/thread-1372101-1-1.html，利用动态链接库"ntdll.dll" 中的函数"RtlComputeCrc32"（即CRC32）作为散列函数。RtlComputeCrc32返回一个32位的长整数，碰撞概率约2^32分之一，但是计算速度比MD5快很多，是一种廉价而高效的算法，基本上也能满足运用需求。代码证返回的32位的长整数跟&H7FFFFFFF按位与，是把返回值的最高位置为0，因为&H7FFFFFFF=01111111111111111111111111111111，这样就能保证是正数了（对VBA来说，Long数据类型最高位为1时是负数，负数 mod 哈希表的大小是负数，负数不便作为数组的下标）。这里不再举例，感兴趣的可以去研究一下，也许哪天用得到呢。
CRC32的算法VBA代码没有，但MD5的算法代码却很多，这里复制一份让大家切身体会一下。代码源于网络，感谢原作者。
（附件）