第2章 查找引用

Sub 查询并标识()
  Dim rng As Range, RngTemp As Range, cell As Range  '声明3个Range对象变量
'将C2到C列最后一个非空单元格所代表的区域赋值给变量Rng，这是被查找的区域
  Set rng = Range([c2], Cells(Rows.Count, "C").End(xlUp))
  For Each cell In rng  '利用For...Next循环遍历Rng区域每个单元格
    If Len(cell) > 0 Then  '仅仅对长度大于0的单元格进行查询
      If cell.Value < 60 Then  '如果值小于60
      If RngTemp Is Nothing Then
  '如果变量RngTemp未初始化，那么将找到的单元格左边偏移两位的单元格赋值给变量
RngTemp
        Set RngTemp = cell.Offset(0, -2)
      Else
  '否则将变量RngTemp与找到的单元格向左偏移两位的单元格合并，然后赋值给变量RngTemp
        Set RngTemp = Union(RngTemp, cell.Offset(0, -2))
      End If
      End If
    End If
  Next cell
  '如果变量RngTemp未初始化则提示
  If RngTemp Is Nothing Then
    MsgBox "不存在不及格学生", 64, "提示"
  Else  '否则对变量所代表的区域添加黄色背景并选择目标单元格
    RngTemp.Interior.ColorIndex = 6
    RngTemp.Select
  End If
End Sub

For Each 变量 In 集合
一条或多条语句
[Exit For]
一条或多条语句
Next [变量]

Sub 查询并标识2()
  Dim rng As Range, RngTemp As Range, i As Integer, j As Integer
  Dim arr(), cell  '声明一个数组和一个变体型变量
  '将C2到C列最后一个非空单元格所代表的区域赋值给数组Arr
  arr = Range([c2], Cells(Rows.Count, "C").End(xlUp)).Value
  i = 1  '因第一行是标题，不参与查找，所以初始化变量值为1
  For Each cell In arr  '利用For...Next循环遍历数组arr，比遍历单元格区域更快
    i = i + 1  '累加变量i，该值对应于查到的目标值所在行
    If Len(cell) > 0 Then  '仅仅对长度大于0的成绩进行查询
      If cell < 60 Then
        j = j + 1  '如果值小于60则累加变量J，该变量对应于目标值数量
        If j = 1 Then
          '如果变量RngTemp未初始化，那么将A列i行单元格赋值给变量RngTemp
          Set RngTemp = Cells(i, "A")
        Else
        '否则将变量RngTemp与A列i行单元格合并，然后赋值给变量RngTemp
        Set RngTemp = Union(RngTemp, Cells(i, "A"))
      End If
    End If
  End If
  Next cell
  '如果J=0则提示，否则对变量所代表的区域添加黄色背景
  If j = 0 Then MsgBox "不存在不及格学生", 64, "提示" Else
RngTemp.Interior.ColorIndex = 6: RngTemp.Select
End Sub

Sub 一次性罗列表中三省员工的姓名()  'Find循环法，通用于Excel 2002、2003、2007和2010
  Dim rng As Range, RngTemp As Range, firstAddress As String
  '声明需要使用的变量
  Dim i As Byte, FindCell As Range, ShtName As String, sht As Worksheet
  '将待查找的目标区域C2到C列最后一个非空单元格赋予对象变量
  Set rng = Range([c2], Cells(Rows.Count, "C").End(xlUp))
    '将四川省、湖南省和湖北省转换成数组，然后循环数组每个元素。数组的基数默认为0，从0递增
  For i = 0 To UBound(Array("四川省", "湖南省", "湖北省"))
      '本例中数组的上限为2，但为了提升程序的通用性，利用UBound计算而不是手工指定
      '开始查找数据，按值精确查找，不区分大小写
      Set RngTemp = rng.Find(What:=Array("四川省", "湖南省", "湖北省")(i),
LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
    If Not RngTemp Is Nothing Then  '如果变量RngTemp不再是Nothing，即找到目标值
      firstAddress = RngTemp.Address  '记录第一个目标的地址
      Do  '只要找到的单元格的地址不等于刚才记录的地址就一直循环下去
        '如果变量FindCell未初始化则将查找结果赋予它，否则合并该变量到查到的单元格
        If FindCell Is Nothing Then Set FindCell = RngTemp Else Set FindCell
        = Union(FindCell, RngTemp)
        Set RngTemp = rng.FindNext(RngTemp)  '查找下一个
      Loop While RngTemp.Address <> firstAddress
    End If
  Next i
  '如果变量FindCell已初始化，就选择所有目标的整行，否则提示并退出程序
  If Not FindCell Is Nothing Then FindCell.EntireRow.Select Else MsgBox"
  没有符合条件的数据": Exit Sub
  On Error Resume Next  '防错，有错误时继续下一步
  ShtName = ActiveSheet.Name  '记录当前表的名称
  Set sht = Sheets("查询结果")  '将工作表“查询结果”赋予变量sht。目的是判断有没
  '有这个工作表
  If Err.Number <> 0 Then  '如果出错，则表示不存在“查询结果”工作表
    Sheets.Add after:=Sheets(Sheets.Count)  '在最末尾创建一个工作表
    Sheets(Sheets.Count).Name = "查询结果"  '将新表命名为“查询结果”
  Else  '否测，清空“查询结果”原有数据
    Sheets(Sheets.Count).Cells.Clear
  End If
  Sheets(ShtName).Select  '返回刚才查找的工作表
  '将选择的所有对象复制到“查询结果”表中
  Selection.Copy Sheets(Sheets.Count).[a1]
End Sub

Sub 一次性罗列表中三省员工的姓名2()  '筛选法，通用于Excel 2007和2010
  Dim sht As Worksheet
  With Range("a1").CurrentRegion
  '利用WITH语句获取A1的当前区域，避免多次引用，提升速度
    '以第三列为条件，筛选出“湖北省”、“湖南省”、“四川省”三类数据，Excel 2003
    '无此功能
    .AutoFilter Field:=3, Criteria1:=Array("湖北省", "湖南省", "四川省"),
    Operator:=xlFilterValues
    On Error Resume Next  '防错，有错误时继续下一步
    ShtName = ActiveSheet.Name  '记录当前表的名称
    Set sht = Sheets("查询结果")  '将工作表“查询结果”赋予变量sht，目的是判断有
    '没有这个工作表
    If Err.Number <> 0 Then  '如果出错，则表示不存在“查询结果”工作表
      Sheets.Add After:=Sheets(Sheets.Count)  '在最末尾创建一个工作表
      Sheets(Sheets.Count).Name = "查询结果"  '将新表命名为“查询结果”
    Else  '否则，清空“查询结果”原有数据
      Sheets(Sheets.Count).Cells.Clear
    End If
    Sheets(ShtName).Select  '返回刚才查找的工作表
    '将筛选后的所有对象复制到“查询结果”表中
    .SpecialCells(xlCellTypeVisible).Copy Sheets(Sheets.Count).[a1]
    .AutoFilter  ' 取消筛选状态
  End With
End Sub

'启动窗体时执行，功能是对窗体中的ListView1控件进行基本设置
Private Sub UserForm_Initialize()
  With ListView1
    .ColumnHeaders.Add , , "姓名", 60  '添第一列表头，宽度为60
    .ColumnHeaders.Add , , "语文", 55  '添第二列表头，宽度为55
    .ColumnHeaders.Add , , "数学", 55  '添第三列表头，宽度为55
    .View = lvwReport   '报表形式显示ListView1控件
    .Gridlines = True    '显示网格线
  End With
  TextBox1.SetFocus  '对文本框设置焦点，类似于单击文本框
End Sub
'文本框中输入字符时执行此命令
Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal
Shift As Integer)
  Dim firstAddress As String, rng As Range  '声明需要用到的变量
  ListView1.ListItems.Clear   '清除ListView控件的所有值
  If TextBox1.Text = "" Then GoTo line '如果文本框是空白则执行Line标签后面的命令
  With Range("a:a")
  '对A列进行查找，按值模糊查找
    Set rng = .Find(TextBox1.Text, LookIn:=xlValues, Lookat:=xlPart)
    If Not rng Is Nothing Then  '如果找到目标
      firstAddress = rng.Address  '记录第一个找到单元格的地址
      Do  '继续查找，直到找到的单元格地址等于刚才记录的单元格地址时停止
      Set Item = ListView1.ListItems.Add() '对ListView1控件添加列表项
      Item.Text = rng.Text                         '第一列显示找到的单元格字符
        Item.SubItems(1) = rng.Offset(0, 1).Text '第二列显示右移一个单元格
        Item.SubItems(2) = rng.Offset(0, 2).Text '第三列显示右移两个单元格
        Set rng = .FindNext(rng)  '查找下一个
      Loop While rng.Address <> firstAddress
    End If
  End With
line:  '指定一个标签，让程序在指定条件下可以跳转到此处继续执行
  '让ListView1控件的高度随查到的值的多少而变化，从而让窗体更美观
  ListView1.Height = ListView1.Font.Size * ListView1.ListItems.Count + 20
  Me.Height = ListView1.Height + 70  '让窗体随ListView1的高度自动变化
End Sub

Sub 查询()
UserForm1.Show 0
End Sub

Sub 按格式查找()
  Dim FindStr As String, Rng As Range, mRng As Range
  Application.FindFormat.Clear '清除原有格式
  With Application.FindFormat  '设置查找格式
    .Font.Name = "Arial Black" '指定字体
    .Font.Bold = True            '加粗
    .Interior.Color = 65535     '黄色背景
  End With
  With Range("C:C") '在C列查找
    Set Rng = .Find(What:="", LookIn:=xlFormulas, LookAt:=xlPart,Search
    Format:=True) '按格式查找
    If Rng Is Nothing Then MsgBox "没有找到此类单元格": Exit Sub '如果找不到则退出
    Set mRng = Rng '将找到的对象赋予另一个变量
    FindStr = Rng.Address '取第一个找到的单元格的地址
    Do
      Set mRng = Union(mRng, Rng)
      '合并变量mrng和找到的单元格（如果有多个符合条件，则逐一合并）
      Set Rng = .Find(What:="", After:=Rng, SearchFormat:=True) '查找下一个
    '直到找到的单元格的地址等于第一个单元格地址时停止
    Loop While FindStr <> Rng.Address
    mRng.Select '选择所有符合条件的单元格
    End With
End Sub

Sub 替换字体格式()
  Application.FindFormat.Clear      '清除原有查找格式
  Application.ReplaceFormat.Clear  '清除原有替换格式
  Application.FindFormat.Font.Size = 10             '查找10号字体
  Application.ReplaceFormat.Font.ColorIndex = 3   '替换为红色字体色
  Application.ReplaceFormat.Font.Size = 12         '替换为12号字体
'开始替换
  [c:c].Replace What:="", Replacement:="", LookAt:=xlPart,
SearchFormat:=True, ReplaceFormat:=True
End Sub

Sub 删除10号字体单元格()
  Application.FindFormat.Clear              '清除原有查找格式
  Application.ReplaceFormat.Clear          '清除原有替换格式
  Application.FindFormat.Font.Size = 10   '查找10号字体
'开始替换
  [c:c].Replace What:="*", Replacement:="", LookAt:=xlPart,Search Format:=True
  End Sub

Sub 替换指定字符标识为上标()
    Dim rng As Range, i As Integer, First As String, inputt As String
    inputt = InputBox("请指定需要上标显示的字符，只有一个字符", "指定字符", "#")
    '指定需要上标的字符
    Application.ScreenUpdating = False    '关闭屏幕更新，从而提速
    Set rng = Cells.Find(inputt, LookAt:=xlPart, LookIn:=xlFormulas)
    '开始查找
    If Not rng Is Nothing Then    '如果找到
      First = rng.Address     '记录首个符合条件的单元格的地址
      Do   '循环查找，直到返回第一个找到的单元格时停止
      For i = 1 To Len(rng)  '循环检查每一个字符
      '如果某字符等于用户输入的字符，则将它上标显示
        If Mid$(rng, i, 1) = Left(inputt, 1) Then rng.Characters(Start:=i,
        Length:=1).Font.
        Superscript = True
      Next
      Set rng = Cells.FindNext(rng)  '查找下一个
      Loop Until rng.Address = First
    End If
    Application.ScreenUpdating = True '恢复屏幕更新
End Sub

Sub 将M后面的2标识为上标()
    Dim rng As Range, i As Integer, First As String, inputt As String
    Application.ScreenUpdating = False    '关闭屏幕更新，从而提速
    Set rng = Cells.Find("M2", LookAt:=xlPart, LookIn:=xlFormulas)  '开始查找
    If Not rng Is Nothing Then    '如果找到
      First = rng.Address     '记录首个符合条件的单元格的地址
      Do   '循环查找，直到返回第一个找到的单元格时停止
      For i = 2 To Len(rng)  '循环检查每一个字符，从第二位开始
      '如果某字符等于2且前一位是“M”，则将它上标显示
        If Mid$(rng, i, 1) = "2" And Mid$(rng, i - 1, 1) = "M" Thenrng.
        Characters(Start:=i, Length:=1).Font.Superscript = True
      Next
      Set rng = Cells.FindNext(rng)     '查找下一个
      Loop Until rng.Address = First
    End If
    Application.ScreenUpdating = True    '恢复屏幕更新
End Sub

Sub 取出还款时间超过一年及未还款的客户()  '其余客户的资料隐藏
  Dim rng As Range, cell As Range
  For Each rng In Range([c2], Cells(Rows.Count, 3).End(xlUp))
  '对C列所有数据区域进行查找
    If Len(rng.Offset(0, 1)) > 0 Then '如果对应的D列值长度大于0
    '如果还款时间超过购货时间12个月以内
      If Evaluate("Datedif(" & rng.Address & ", " & rng.Offset(0, 1).Address
      & ", ""M""" & ")") < 12 Then
      '将所有符合条件的单元格合并
      If cell Is Nothing Then Set cell = rng Else Set cell =Application.
      Union(cell, rng)
      End If
    End If
  Next rng
  '如果有符合条件的单元格，则将它隐藏（剩下的是还款时间超过一年以及未还款的客户）
  If Not cell Is Nothing Then cell.EntireRow.Hidden = True
End Sub

Dim MyData As DataObject  '必须引用MS Form 2.0
Sub 查找三个班第一名并写入剪贴板()
  Dim arr, rng, i As Integer, One As Byte, Two As Byte, Three As Byte
  Dim a As Byte, b As Byte, c As Byte
  Set MyData = New DataObject '建立一个DataObject 对象
  arr = Range([a1], Cells(Rows.Count, 3).End(xlUp)).Value
  '将所有数据赋予数组，从而提速
  For i = 1 To UBound(arr) '遍历数组所有行
  '如果某行第一列等于“一班”，而且该行第三列大于变量One，那么取出其行号和成绩
    If arr(i, 2) = "一班" And arr(i, 3) > One Then One = arr(i, 3): a = i
    If arr(i, 2) = "二班" And arr(i, 3) > Two Then Two = arr(i, 3): b = i
    If arr(i, 2) = "三班" And arr(i, 3) > Three Then Three = arr(i, 3): c = i
  Next
  '将找到的所有数据串接起来，复制到 DataObject对象
  MyData.SetText arr(a, 1) & ": " & One & Chr(10) & arr(b, 1) & ": " & Two
  & Chr(10) & arr(c, 1) & ": " & Three
  MyData.PutInClipboard '最后写入剪贴板
End Sub

If MyData.GetFormat(1) Then MsgBox MyData.GetText(1)

Sub 查找三个班第一名并写入剪贴板2()
  Set MyData = New DataObject '建立一个DataObject 对象
  Dim str As String
  str = Evaluate("=INDEX(A2:A37,MATCH(MAX(IF(B2:B37=""一班"",C2:C37)),
  IF(B2:B37=""一班"",C2:C37),0))")
  str = str & ": " & Evaluate("MAX(IF(B2:B37=""一班"",C2:C37))")
  str=str & Chr(10) & Evaluate("=INDEX(A2:A37,MATCH(MAX(IF(B2:B37=
  ""二班"",C2:C37)),IF(B2:B37=""二班"",C2:C37),0))")
  str = str & ": " & Evaluate("MAX(IF(B2:B37=""二班"",C2:C37))")
  str=str & Chr(10) & Evaluate("=INDEX(A2:A37,MATCH(MAX(IF(B2:B37=
  ""三班"",C2:C37)),IF(B2:B37=""三班"",C2:C37),0))")
  str = str & ": " & Evaluate("MAX(IF(B2:B37=""三班"",C2:C37))")
  MyData.SetText str
  MyData.PutInClipboard
End Sub

Sub auto_open() 'auto_open表示打开文件时就执行
  On Error Resume Next '防错
  CommandBars("Formatting").Controls("请输入查找内容").Delete
  '删除上次产生的工具栏
  CommandBars("Formatting").Controls("查找").Delete
  '创建新的工具栏，位于格式工具栏末尾
  With CommandBars("Formatting").Controls.Add(Type:=msoControlButton,
  Temporary:=True)
    .Caption = "请输入查找内容" '工具栏显示的标题
    .BeginGroup = True '显示一条分隔线
.TooltipText = "请输入查找内容" '鼠标指向时出现提示
.Style = msoButtonCaption '显示文字
  End With
  '再创建一个文字框菜单
  With CommandBars("Formatting").Controls.Add(Type:=msoControlEdit,Temporary:
  =True)
    .Caption = "查找" '指定显示标题
    .Text = ""    '默认显示空白
    .OnAction = "intos" '关联的宏，表示输入文字后按回车键时执行的过程名称
  End With
End Sub
Sub intos()
  With ActiveSheet.UsedRange '在当前表已用区域中查找
    Dim rng As Range, rngg As Range, firstAddress As String
Set rng = .Find(CommandBars("Formatting").Controls("查找").Text, LookIn:
=xlValues,lookat:=xlPart)
 If Not rng Is Nothing Then '如果找到
      firstAddress = rng.Address '记录第一个单元格地址
      Do '循环执行，直到返回第一个单元格
      '将找到的所有单元格合并为一个Range对象
        If rngg Is Nothing Then Set rngg = rng Else Set rngg = Union(rng,rngg)
        Set rng = .FindNext(rng) '查找下一个
      Loop While rng.Address <> firstAddress
      rngg.Select '选择所有符合条件的单元格
      MsgBox "已找到目标所在地址：" & rngg.Address(0, 0) '报告地址
      End
    End If
    MsgBox "没找到" '未找到时也提示
  End With
End Sub

Sub 查找最后一次报价()
  On Error Resume Next '防错，确保Collection对象能正常执行
  Dim Only As New Collection, i As Integer, j As Integer
  Dim arr, Arr2()
  arr = Range([a1], Cells(Rows.Count, 3).End(xlUp)).Value
  '将区域转换成数组，从而提速
  For i = UBound(arr) To 1 Step -1
  '遍历数组所有行，为了保留最后日期的价格，则从后向前循环
  '将数组第一列i行的品名添加到Collection对象中，如果存在重复，仅取首次出现者
    Only.Add arr(i, 1), CStr(arr(i, 1))
    If Err = 0 Then '如果没有错误(表示当前产品名称是第一次写入Collection对象)
      j = j + 1 '累加变量，该变量等于产品个数（不含重复值）
      ReDim Preserve Arr2(1 To 3, 1 To j)
      '重新分配存储空间（只能修改最末一维的大小）
      Arr2(1, j) = Only(j)    '将Collection对象中的值导入数组arr2
      Arr2(2, j) = arr(i, 2) '将数组arr中j行的值也写入数组
      Arr2(3, j) = arr(i, 3)
    End If
    Err.Clear '每循环一次自动清除错误（必需的，否则不能取出后面的产品、价格和日期）
  Next i
  [e1].Resize(j, 3) = WorksheetFunction.Transpose(Arr2)
  '将数组arr2的值转置后写入单元格
  [g1].Resize(j, 1).NumberFormatLocal = "m月d日" '将存放日期的单元格设置为日期格式
  [h1].Resize(j, 1) = Evaluate("=row(1:" & j & ")")
  '创建一个辅助区，利用它将倒序的数据修正
  '对产生的数据进行排序,以辅助区为标准倒序排列.可以使原本倒序的按原来的升序显示
  [e1].Resize(j, 4).Sort Key1:=[h1], Order1:=xlDescending,
OrderCustom:=1,
  Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
  [h1].Resize(j, 1).Clear '清除辅助区
End Sub

Dim X As New Collection

Dim rng As Range  '声明一个公共变量
Private Sub UserForm_Activate()  '窗体激活时执行
    For Each rng In [A2].Resize(ActiveSheet.UsedRange.Rows.Count - 1, 1)
        If Len(rng) > 0 Then 部门.AddItem rng.Text
        '将A列除A1之外的所有非空单元格添加到“部门”组合框
    Next
部门 = 部门.List(0)  '默认显示列表中第一个值
End Sub
Private Sub 部门_Change()
项目组.Clear  '当“部门”组合框修改时清除“项目组”的列表
    Dim i As Integer
    '在A列查找“部门”组合框的值，并记录其行号
    i = [a:a].Find(What:=部门.Text, After:=[a1], LookIn:=xlValues,
LookAt:=xlPart).Row
    '在A列查找到的单元格所在的合并区域对应的B列单元格中循环，如A2:A5对应B2:B5
    For Each rng In Cells(i, 2).Resize(Cells(i, 1).MergeArea.Rows.Count, 1)
        If Len(rng) > 0 Then Me.项目组.AddItem rng.Text '如果非空则追加到组合框
    Next rng
项目组=项目组.List(0) '默认显示列表中第一个值
End Sub
Private Sub 项目组_Change()
    If Len(项目组) = 0 Then Exit Sub  '如果组合框“项目组”为空时则退出程序
姓名.Clear  '清空“姓名”组合框
    Dim i As Integer
    '在B列查找“项目组”组合框的值，并记录其行号
    i = [B:B].Find(What:=项目组.Text, After:=[B1], LookIn:=xlValues,
LookAt:=xlPart).Row
    For Each rng In Cells(i, 3).Resize(Cells(i, 2).MergeArea.Rows.Count, 1)
        If Len(rng) > 0 Then 姓名.AddItem rng.Text '如果非空则追加到组合框
    Next rng
姓名 = 姓名.List(0) '默认显示列表中第一个值
End Sub
Private Sub 姓名_Change()
    If Len(姓名) = 0 Then Exit Sub '如果“姓名”组合框为空时则退出程序
    Dim i As Integer
    '在C列查找“姓名”组合框的值，并记录其行号
    i = [C:c].Find(What:=姓名.Text, After:=[C1], LookIn:=xlValues,
LookAt:=xlPart).Row
得分 = Cells(i, 4)  '将D列i行的值赋予“得分”控件，即最后需要查询的目标值
End Sub

Sub 评分查询()
    UserForm1.Show 0
End Sub

Private Declare Function ShellExecute Lib "shell32.dll" Alias
"ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String,ByVal nShowCmd As Long) As Long
Sub 批量发邮件()  '每次发一人的资料
Dim rng As Range, MyMail As String
For Each rng In Range([b2], Cells(Rows.Count, 2).End(xlUp))
 MyMail = "mailto:" & rng.Offset(0, 1).Text & "?subject=成绩通知&body=" &rng.Offset(0, -1) & "：%0A你的总分为：" & rng.Text & "%0A%0A" + Space(20)& "通知日期：" & Date
    ShellExecute 0&, vbNullString, MyMail, vbNullString, vbNullString, 1 Next
End Sub

Sub 批量发邮件2()  '一次发给多人邮件
  Dim rng As Range, MyMail As String, str As String, Temp As String, i As Integer
  For Each rng In Range([c2], Cells(Rows.Count, 3).End(xlUp))
    str = str & rng.Text & ";"
  Next
  For Each rng In Range([A2], Cells(Rows.Count, 2).End(xlUp))
    i = i + 1
    Temp = Temp & rng.Text & IIf(i Mod 2, "     ", "%0A")
  Next
  MyMail = "mailto:" & Mid$(str, 1, Len(str) - 1) & "?subject=成绩通知&body=
  成绩表：%0A" & Temp & "%0A%0A" + Space(20) & "通知日期：" & Date
  ShellExecute 0&, vbNullString, MyMail, vbNullString, vbNullString, 1
End Sub