- Excel 2010 VBA编程与实践
- 罗刚君 章兰新 黄朝阳编著
- 987字
- 2020-08-27 02:13:49
2.2 跨表及多表查找
在多个工作表中将查找结果返回到同一个表或者窗体，这是VBA的强项。利用VBA可以瞬间完成各种需求的跨表查询，以及对查询的目标进行计算或者格式设置。
疑难36 如何引用数据表创建多级下拉菜单
数据有效性可以实现下拉菜单，但只能一级。那么可以实现二级菜单吗?例如利用图2-30所示的数据产生图2-31所示的二级菜单，当单击单元格时，产生二级菜单；选择第二级菜单时可以在单元格分别产生部门和姓名，即同时输入一级和二级菜单的字符。
█ 图2-30 数据表
█ 图2-31 二级菜单
解决方案
数据有效性功能无法修改，但可以通过自定义二级菜单的方式来处理。ShowPopup方法可以将二级菜单显示在活动单元格处，从而打造出类似于数据有效性下拉列表的二级菜单。最后利用ActionControl属性获取用户所单击的菜单字符，并导入到单元格中。
简单而言，就是利用工作簿事件 SheetSelectionChange，在选择指定的单元格时利用CommandBars.Add创建一级和二级菜单，而当用户选择菜单时，将菜单的文字标题导入到单元格中。
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 选择菜单“插入”→“模块”，并输入以下代码：
Sub 选项() '用于指定哪个区域可以产生二级菜单
Dim i As String, adds As String, sht As Worksheet
'确认是否存在“数据”工作表
On Error Resume Next
Set sht = Sheets("数据")
If err.Number <> 0 Then MsgBox "请建立一个名为“数据”的工作表，用于存放菜单
所需要的数据", , "确认数据表": GoTo err
err.Clear
On Error GoTo err
'如果选择的是单元格，那么将选区地址赋予变量adds，否则将“B:B”赋予变量
If TypeName(Selection) = "Range" Then adds = Selection.Address(0, 0) Else
adds = "B:B"
i = Application.InputBox("你想控制哪一个区域" & vbCrLf & "如果想关闭本功能，
单击取消按钮即可。", "请选择区域", adds, , , , , 8).Address(0, 0)
SaveSetting "MyApp", "only", "only", i '将用户选择的单元格地址存入注册表
Exit Sub '退出程序
err:
SaveSetting "MyApp", "only", "only", "" '在注册表中写入一个空字符
End Sub
以上过程用于让用户指定在哪个区域产生二级菜单，可以利用【Ctrl】键多选。而用户选择的区域地址将会存储在注册表中。
步骤3 如果VBE编辑器左边没有对象浏览器，那么选择菜单“视图”→“对象浏览器”调出对象浏览器窗口。然后双击“ThisWorkbook”进入代码窗口，并输入以下工作簿级别事件过程代码：
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target
As Range)
If GetSetting("MyApp", "only", "only", "") = "" Then Exit Sub
'如果注册表中没有值则退出
If Target.Count > 1 Then Exit Sub '如果选择区域则退出
On Error Resume Next
Dim sht As Worksheet
Set sht = Sheets("数据") '将数据表赋予变量sht
If err <> 0 Then err.Clear: Exit Sub
'如果有错误（即没有“数据”工作表）那么退出
If sht.Range("a1") = "" Then MsgBox "请在数据表中输入数据，必须从A1开始，数
据区不要留空", vbOKOnly, "提示": Exit Sub
Dim a As Range
'判断注册表中记录的单元格与活动单元格是否重叠
Set a = Intersect(Range(GetSetting("MyApp", "only", "only", "")),
ActiveCell)
If a Is Nothing Then Exit Sub '如果不在指定区域则退出
Dim i, j, addss As String
With Application.CommandBars.Add("临时菜单", msoBarPopup, , 1)
'创建一个快捷菜单
With .Controls.Add(Type:=msoControlButton) '添加一个子菜单
.Caption = "请选择" '指定显示标题
.FaceId = 136 '指定图标
End With
For i = 1 To sht.Cells(1, Columns.Count).End(xlToLeft).Column
'创建一级菜单
If WorksheetFunction.CountA(sht.Rows(2)) = 0 Then
'如果第二行为空则只创建一级菜单
With .Controls.Add(Type:=msoControlButton) '开始创建一级菜单
.Caption = sht.Cells(1, i).Text '菜单显示的标题
.Style = msoButtonIconAndCaption '同时显示文本和图标
.FaceId = 70 + i '指定图文件
.OnAction = "输入" '指定菜单对应的宏名
End With
Else '第二行非空则创建二级菜单
With .Controls.Add(msoControlPopup, 1, , , 1) '开如创建二级菜单
.BeginGroup = True '全部产生一条横线分隔开
.Caption = sht.Cells(1, i).Text '指定二级菜单标题
For j = 2 To sht.Cells(Rows.Count, i).End(xlUp).Row
If sht.Cells(j, i) = "" Then GoTo AA '如果为空则不创建子菜单
Set oCtrl = .Controls.Add(Type:=msoControlButton) '创建子菜单
With oCtrl '对子菜单指定标题、宏名和图标
.Caption = sht.Cells(j, i)
.OnAction = "输入"
.FaceId = 69 + j
End With
AA:
Next
End With
End If
Next
.ShowPopup '显示工具栏
End With
Application.CommandBars("临时菜单").Delete '删除工具栏
End Sub
以上事件为工作簿级别的SelectionChange事件，表示用户选择单元格时执行对应的过程。本过程首先判断当前选区是否与注册表中存储的单元格重叠，如果重叠则创建二级菜单，调用“数据”工作表中指定区域的文本作为菜单的显示标题。
步骤4 返回模块中，继续输入过程“输入”的代码：
Sub 输入() '当单击二级菜单时，将菜单的标题字符写入单元格
AA = CommandBars.ActionControl.Caption '记录当前菜单的标题
'在数据表中查找变量aa，并返回找到的目标所在列的第一个单元格（即一级菜单），并写入
'活动单元格
ActiveCell = Sheets("数据").Cells.Find(What:=AA, LookAt:=xlWhole).
EntireColumn.Cells(1)
'如果“数据”工作表第二行有数据，那么将当前菜单的文字写入右边一个单元格（即二级菜单）
If WorksheetFunction.CountA(Sheets("数据").Rows(2)) <> 0 Then
ActiveCell.Offset(0, 1) = AA
End If
End Sub
以上过程是单击菜单时执行的宏过程，用于将一级和二级菜单的显示标题导出到活动单元格及活动单元格右边一个单元格。如果只有一级菜单，则只导入一级菜单的文字。
步骤5 返回工作表界面，在“数据”工作表中按图2-30所示方式输入数据。其中第一行用于创建一级菜单，其他数据用于创建二级菜单；在区域中间不能有空白单元格。
步骤6 切换到“职工表”，选择“开发工具”选项卡，单击【宏】按钮，在弹出的对话框中选择过程名“选项”并单击【执行】按钮，程序会弹出对话框等待用户指定需要产生二级菜单的区域，如图2-32所示。选择一个或者多个区域，程序会将地址保存在注册表中。
█ 图2-32 选择产生二级菜单的区域
步骤7 单击B2:B10区域中任意单元格，将弹出图2-31所示的二级菜单。如果选择菜单“业务部”→“胡大链”，那么B列和C列同时产生“业务部”和“胡大链”，如图2-33所示。
█ 图2-33 使用二级菜单对两个单元格赋值
步骤8 切换到“数据”工作表，将第一行以外的数据删除。返回“职工表”，选择 B4单元格，此时将弹出一级菜单，如图2-34所示。
█ 图2-34 一级菜单
步骤9 切换到“数据”工作表，恢复删除前的所有数据，并且在 E 列追加部门“策划部”和姓名“胡军”、“张英姿”。进入“职工表”，选择B2单元格，在弹出的菜单中也自动追加对应的二级菜单，如图2-35所示。
█ 图2-35 自动添加二级菜单
原理分析
※“ActionControl”对象的功能与限制 ※
“ActionControl”对象代表当前所单击的菜单，可以通过“Caption”属性获取其标题文字，并导入单元格中。不过对于上一层菜单则无法获取，所以利用“OnAction”所指定的SUB过程到指定的区域中查找与“ActionControl”对象的Caption字符串相同的单元格，它所在列的首行标题即为上层菜单所显示的文本。
本例中使用工作簿级事件而不用工作表事件，是为了让程序更具通用性，使其在任意工作表的指定区域中都可以调用二级菜单。“Workbook_SheetSelectionChange”是工作簿级的 SelectionChange 事件，它表示工作簿中选择任意工作表的单元格时执行的过程。如果需要指定某工作表例如“总表”忽略二级菜单，那么可以在事件的代码前加入一句代码：
知识扩展
If Sh.Name = "总表" Then Exit Sub
ShowPopup可以将指定的命令栏作为快捷菜单，在指定坐标或当前光标位置显示。如果指定坐标则在该坐标处显示，否则在鼠标箭头处显示。它可以调用自定义工具栏，例如本案例中的应用，也可以调用所有内置的快捷菜单。例如以下代码显示工作表标签菜单：
CommandBars("PLY").ShowPopup
疑难37 如何将所有表中查找的完成数汇总到总表
图2-36所示包括多个组别的目标产量与实际产量，如何实现将所有组别中完成目标者汇总到总表中?
█ 图2-36 某生产线产量统计表
解决方案
利用循环对“总表”以外的每个工作表进行数据查找。查找前，在D列创建一个辅助区，利用公式“=IF(B2-C2=0,0/0,"")”将所有完成目标者标识一个错误值，再利用SpecialCells方法定位所有错误值所在行，并复制到“总表”中，最后清除所有辅助区。
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 选择菜单“插入”→“模块”，并输入以下代码：
Sub 多表查找并汇总()
Dim sht As Worksheet, arr(), i As Integer
On Error Resume Next '验证是否存在“总表”
Set sht = Sheets("总表")
If Err <> 0 Then '如果不存在“总表”则在最末处添加一个总表
Sheets.Add , after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "总表"
Else '否则清除总表的所有数据
sht.Cells.Clear
End If
Sheets(1).Rows(1).Copy sht.[a1] '将标题行复制到总表
For Each sht In Sheets '遍历所有工作表
If sht.Name <> "总表" Then '仅对总表以外的表进行操作
With sht.Range(sht.[D2], sht.Cells(Rows.Count, 3).End(xlUp).Offset
(0, 1)) '建立辅助区
.FormulaR1C1 = "=IF(RC[-2]-RC[-1]=0,0/0,"""")"
'在辅助区设置公式，当完成值等于目标值时公式返回错误
'定位D列所有错误单元格（即已完成的），并将整行复制到总表中第一个空行
.SpecialCells(xlCellTypeFormulas, 16).EntireRow.Copy Sheets("总表
").Cells(Sheets("总表").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
.Clear '清除辅助区
End With
End If
Next
Sheets("总表").Columns(4).Clear '清除公式所在列
End Sub
步骤3 光标置于代码中任意位置，并按【F5】键执行，程序将对每个表中已完成者信息合并到“总表”中，如图2-37所示。
█ 图2-37 合并所有组别完成数
原理分析
找到完成数且合并到总表，常规思路是利用For...Next循环对C列和B列的值进行比较，如果相等则整行复制到“总表”。然而循环次数太多，效率则相应偏低。本例创建辅助列，利用公式“=IF(B2-C2=0,0/0,"")”将已完成和未完成的单元格区别开来。其中已完成者公式结果为“#DIV/0!”，而SpecialCells方法刚好可以定位这部分单元格，最后再整行复制到总表中。
知识扩展
※ 利用SpecialCells定位实现快速查找 ※
对某列取值或者查找信息有很多思路，而利用SpecialCells定位特殊对象是最简单的。如果数据中有某个特点是 SpecialCells 可以利用的，则直接定位，否则创建辅助区制造出SpecialCells可以利用的条件，再进行定位。
创建辅助区的公式，最简单的思路是在工作表中输入公式，通过录制宏获取代码。
疑难38 在窗体中罗列每月产量冠军名单
图2-38所示包含了多个月的生产数据。如何实现查找每月的产量冠军并同时显示在窗体列表中呢？
█ 图2-38 产量表
解决方案
创建一个窗体，在窗体中添加一个列表框。利用公式“=MATCH(MAX(D2:D21), D2:D21,)”获取每个工作表中生产冠军的所有信息，然后配合 For...Next 循环找出每个月的生产冠军，并导入到数组中。最后将数组一次性赋值给窗体中列表框的List属性。
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 选择菜单“插入”→“用户窗体”，并在属性窗口中将窗体的“Caption”属性修改为“每月产量冠军”；将工具箱中的列表框拖到窗体中，且调整窗体和列表框的大小，使其与图2-39一致。
█ 图2-39 窗体中创建列表框
步骤3 双击窗体进入窗体代码窗口，将自动产生的代码清除，然后重新输入以下代码：
Private Sub UserForm_Activate() '激活窗体时执行
Dim sht As Worksheet, arr(), i As Integer, MaxRow As Integer, EndRow As Integer
Me.ListBox1.ListStyle = fmListStyleOption '指定列表框的显示外观
Me.ListBox1.ColumnCount = 5 '列表框显示5列
Me.ListBox1.ColumnWidths = "40,40,40,40,40" '每列的宽度为40
i = 1
ReDim Preserve arr(1 To 5, 1 To i) '重新分配数组的存储空间
arr(1, i) = "月份" '指定列表框的标题
arr(2, i) = "姓名"
arr(3, i) = "机台"
arr(4, i) = "组别"
arr(5, i) = "产量"
For Each sht In Sheets '遍历所有工作表
i = i + 1 '累加变量
EndRow = sht.Cells(Rows.Count, 1).End(xlUp).Row
'找到工作表的最后非空行行号
'利用公式计算每个工作表中D列最大值所在的行号
MaxRow = Evaluate("=MATCH(MAX(" & sht.Name & "!D2:D" & EndRow & "),"
& sht.Name & "!D2:D" & EndRow & ",)") + 1
ReDim Preserve arr(1 To 5, 1 To i)
arr(1, i) = sht.Name '数组1行i列写入工作表名
arr(2, i) = sht.Cells(MaxRow, 1) '2行i列写入姓名
arr(3, i) = sht.Cells(MaxRow, 2) '3行i列写入机台
arr(4, i) = sht.Cells(MaxRow, 3) '4行i列写入组别
arr(5, i) = sht.Cells(MaxRow, 4) '5行i列写入产量
Next
Me.ListBox1.List = WorksheetFunction.Transpose(arr)
'将数组倒置后写入列表框
End Sub
步骤4 选择菜单“插入”→“模块”，并在模块中输入以下代码：
Sub 多表查找() UserForm1.Show 0 End Sub
步骤5 执行过程“多表查找”，将会弹出图2-40所示的窗体，罗列出每月的产量冠军。
█ 图2-40 在窗体中罗列所有产量冠军
原理分析
本案例中有两个亮点：VBA中套用公式计算最大值所在行和利用数组对列表框赋值。
※ 不采用循环，一次性找出最大值所在行 ※
查找一列中最大值，通常采用循环来进行。本案例中利用 Evaluate 方法计算公式“=MATCH(MAX(D2:D21),D2:D21,)”，从而一次性找出最大值所在行，避免循环。不过公式需要记录不同工作表的最大值，所以在引用区域前需要添加表名。
当找到最大值及最大值对应的姓名、机台和组别时，将它导入到数组中，最后将数组赋予列表框的List属性，在窗体中展示查找结果，且包括查找值的相关资料。
知识扩展
公式“=MATCH(MAX(D2:D21),D2:D21,)”用于查找 D2:D21区域中最大值所在行。为了体现通用性，其中21利用VBA计算得出。不过如果一列中有多人产量相同时，仅取第一人。如果需要将同产量者全取出，那么需要更换思路，改用Find进行循环查找。
如果要将产量冠军导出到工作表而不是窗体，那么可以将数组一次性写入单元格即可：
[H1].Resize(i, 5) = WorksheetFunction.Transpose(arr)
疑难39 如何将具有外部数据引用的单元格转换成值
如果工作表中引用了其他工作簿的数据，如图2-41所示，当本工作簿寄出给客户或者下属部门后，会因为找不到引用源而失去链接。那么如何删除所有外部链接呢?
解决方案
具有外部链接的公式均有一个特点：公式中包括“[]”和“’！”。那么使用 Find 方法查找包含该字符的公式，转换成数值即可。
█ 图2-41 生产表中引用其他表的单价
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 选择菜单“插入”→“模块”，并输入以下代码：
Sub 查找外部链接并转为值()
Dim Cell As Range, FirstAddress As String, sht As Worksheet
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
For Each sht In Worksheets ' 在所有工作表中循环（注意不是sheets）
With sht.UsedRange '在已用区域中查找
'查找包括“]”和“'!”的公式，它表示该单元格有外部引用。
Set Cell = .Find("=*]*'!", LookIn:=xlFormulas, LookAt:=xlPart)
If Cell Is Nothing Then GoTo line '如果未找到，则执行line标签后的语句
FirstAddress = Cell.Address '记录第一个查找到的单元格地址
Do '循环查找其他单元格
Cell = Cell.Value '将公式转换成值
Set Cell = .FindNext(Cell) '查找下一个
Loop Until Cell.Address = FirstAddress
End With
line:
Set Cell = Nothing '将变量Cell重置为nothing
Next sht
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
步骤3 光标置于代码中任意位置，并按【F5】键执行，所有工作表中引用其他工作簿的公式都瞬间被转换成数值。
原理分析
※ 通过“[]”和“’！”定位具有外部链接的公式 ※
公式引用其他工作簿的数据时，被引用的工作簿被删除或者修改名称、移动名称等都会造成公式结果错误。将文件下发或者邮件发送前有必要将具有外部引用的公式转换成数值。根据外部链接公式的特点：包括“[]”和“’！”。所以利用 Range.Find 方法查找具有该特征的单元格即可，通过等号赋值将找到的单元格转换成值。
知识扩展
Find方法查找不到对象时，返回Nothing。而本例中如果本工作表不存在外部引用，那么变量Cell即为Nothing，此时它不存在Address属性，所以在代码中必须使用防错语句。
疑难40 如何让链接到其他表中隐藏单元格的超链接生效
超级链接可以单击进入其他工作表指定的单元格。然而链接的工作表被隐藏时，链接将失效，如图2-42所示。如何实现链接到隐藏表时也能生效呢？
█ 图2-42 链接到隐藏工作表的超链接
解决方案
首先利用Range(Target.SubAddress)方法判断链接对象是否为单元格，如果是其他工作表的单元格，那么先取消所引用的工作表的隐藏属性，然后选择被链接所引用的单元格。此过程必须通过工作簿事件SheetFollowHyperlink自动执行。
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 如果未显示工程资源管理器，那么选择菜单“视图”→“工程资源管理器”。双击管理器中的“ThisWorkbook”进入工作簿事件代码窗口，并输入以下代码：
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target
As Hyperlink)
On Error Resume Next '防错，避免超级链接的对象为非单元格
Dim sht As Worksheet '声明一个工作表对象变量
Set sht = Range(Target.SubAddress).Parent '提取链接单元格所在工作表
If Err = 0 Then '如果未出现错误（表示链接对象是单元格）
If Not sht. xlSheetVisible = xlSheetVisible Then
'如果工作表sht处于隐藏状态
Range(Target.SubAddress).Parent.Visible = True '取消隐藏状态
Range(Target.SubAddress).Parent.Select '选择链接对象所在的工作表
Range(Target.SubAddress).Select '选择链接对象
End If
End If
End Sub
步骤3 返回工作表“生产表”，单击单元格C2，C2的超链接对象“单价表”将自动显示，且链接到B1也立即生效。
原理分析
工作簿事件 SheetFollowHyperlink 在单击具有超链接的单元格时发生。本例利用该事件执行过程，可以实现单击超链接时判断该链接的引用工作表的单元格地址，将该表取消隐藏后选择对应的单元格即可。
事件过程的参数Target代表当前链接，其SubAddress属性包括了引用的表及单元格。
知识扩展
Parent表示上层对象。单元格对象的上层是工作表，工作表对象的上层是工作簿。
※ 通过xlSheetVisible属性切换工作表显示状态 ※
工作表的xlSheetVisible属性表示显示状态，赋值为xlSheetVisible时表示显示工作表。前置Not后则表示工作表处于隐藏状态。
疑难41 如何实现多部门电话资料模糊查询
公司多个部门的电话存储在多个工作表中，如图2-43所示。如何实现“查询表”的A1单元格输入任意字符时，在多部门间查找姓名中包含该字符的电话信息？
█ 图2-43 电话簿
解决方案
利用工作表Change事件调用Range.Find方法实现多表模糊查找。将找到的目标导入到数组，查询完毕后再一次性导出到工作表中。
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 如果未显示工程资源管理器，那么选择菜单“视图”→“工程资源管理器”使其显示。然后双击管理器中的“查询表”进入工作表事件代码窗口，并输入以下代码：：
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address <> "$A$1" Then Exit Sub '如果活动单元格不是A1则退出程序
Range(Rows("2:2"), Selection.End(xlDown)).ClearContents
'将第一行以外的内容清除
Dim sht As Worksheet, arr(), i As Integer
For Each sht In Sheets '遍历所有工作表
If sht.Name <> "查询表" Then '排除“查询表”
Set Rng = sht.UsedRange.Find(What:=Target.Text, LookIn:= xlValues,
LookAt:=xlPart) '开始查找
If Rng Is Nothing Then GoTo line '如果未找到则跳转至标签line
Set mRng = Rng '将找到的对象赋予另一个变量
FindStr = Rng.Address '取第一个找到的单元格的地址
Do
i = i + 1 '累加变量
ReDim Preserve arr(1 To 4, 1 To i) '重置数组变量存储空间
arr(1, i) = sht.Name '数组1行i列写入工作表名
arr(2, i) = Rng.Text '数组2行i列写入姓名
arr(3, i) = Rng.Offset(0, 1) '性别
arr(4, i) = Rng.Offset(0, 2) '电话
Set Rng = sht.UsedRange.FindNext(Rng) '查找下一个
Loop While FindStr <> Rng.Address
'直到找到的单元格的地址等于第一个单元格地址时停止
End If
line:
Next
[a2].Resize(i, 4) = WorksheetFunction.Transpose(arr)
'将数组倒置后写入列表框
End Sub
步骤3 关闭VBE窗口，进入“查询表”中，在A1单元格中输入“张”并按下回车键，程序会在所有部门查找姓名中包括“张”的职员的信息，罗列在A1单元格之后的区域，按数组的大小自动扩展区域。显示的值包括部门和姓名、性别、电话，如图2-44所示。
█ 图2-44 多部门电话查询结果
原理分析
工作表事件 Change 用于代码所在工作表中任意单元格的值产生变化时执行指定的过程。该事件常会引起递归现象，所以使用 Change 事件时，通常配合“Application.EnableEvents =False”或者判断Target是否指定单元格的方式来进行防范。
多表查询电话，本例按姓名查询，只要一个字符符合条件即可。那么Range.Find方法的参数LookAt必须使用xlPart，表示模糊查找。而如果不是包含关系，而是强调“姓”，即左边一位或者两位等于Target的值，那么Find的参数可以如下设置：
Find(What:=Target.Text & "*", LookIn:=xlValues, LookAt:=xlWhole)
知识扩展
※ Target与Activecell的区别 ※
工作表事件的过程有一个代表Range对象的参数Target，该参数代表活动工作表中选定的区域。它和Activecell有所区别，Target可能是一个单元格，也可能是区域，而Activecell则只能是一个单元格。
多表查找一定要考虑某表不存在目标值的情况，通常利用“If Rng Is Nothing…”语句来防错，确保程序不会中途弹出错误信息框。
疑难42 如何实现所有未收货款者在状态栏随机显示
工作簿中有数十个客户的货款回收信息，其中部分客户未收款，如图2-45所示。如何才能打开工作簿时自动在状态栏随机显示未收款的客户，并且每2秒钟更新一次？
█ 图2-45 收款记录表
解决方案
利用“Auto_open”作为过程名，使其具有自启动的功能。在过程中利用 Range.Find 方法查找未付款的客户，并将其导入数组变量中，同时记录未收款的客户数量。然后利用另一个过程每隔2秒钟将数组中的客户名称展现在状态栏中。
操作方法
步骤1 按【Alt+F11】组合键打开VBE窗口。
步骤2 选择菜单“插入”→“模块”，并输入以下代码：
Dim arr(), i '声明公共变量，供两个SUB过程调用
Sub auto_open()
Dim sht As Worksheet, rng As Range, FindRng As Range, FindStr As String
For Each sht In Sheets '遍历所有工作表
'获取C列收款时间所有区域（由于单元格可能为空，以A列最后一行为标准）
Set rng = sht.Range(sht.[c2], sht.Cells(Rows.Count, 1).End(xlUp).
Offset(0, 2))
Set FindRng = rng.Find(What:="", LookAt:=xlWhole) '查找空白单元格
If FindRng Is Nothing Then GoTo line '如果未找到则跳转至标签line
FindStr = FindRng.Address '取第一个找到的单元格的地址
Do
i = i + 1 '累加变量
ReDim Preserve arr(1 To i) '重置数组变量存储空间
arr(i) = FindRng.Offset(0, -2).Text
'将找到空单元格左边偏移两位（即客户名）写入数组
Set FindRng = sht.UsedRange.FindNext(FindRng) '查找下一个
Loop While FindStr <> FindRng.Address
'直到找到的单元格地址等于第一个单元格地址时停止
line:
Next
If i > 0 Then Call 随机显示 '执行“随机显示”过程
End Sub
Sub 随机显示()
Application.OnTime Now + TimeValue("00:00:02"), "随机显示" '每两秒钟执行
'在状态栏随机显示数组Arr的值。随机性来自于Rnd函数与客户数量的乘积
Application.StatusBar = "未收款客户：" &
arr(WorksheetFunction.RoundUp(Rnd * i, 0))
End Sub
步骤3 关闭工作簿并重新打开，在状态栏可以显示未收款客户名称，每2秒钟更新一次，如图2-46所示。
█ 图2-46 在状态栏随机显示未收款客户
原理分析
“Auto_open”即为自启动之意，用它作为 SUB 过程名称，则该过程可以在工作簿打开时自动执行，类似于“Workbook_Open”事件。
每2秒钟更新，只能使用OnTime方法在当前时间的2秒钟之后调用过程自身，即递归来实现。而随机调用数组中某个元素，则必须调整数组的参数值在1到其最大上标之间。VBA的 Rnd 函数只能产生0到1之间的小数，所以将其乘以数组的最大上标后，利用工作表函数RoundUp向上进位即可满足需求。
知识扩展
※ 利用OnTime定时执行程序 ※
OnTime的功能为安排一个过程在将来的特定时间运行，既可以是具体某个时间，也可以是某个时段之后的一段时间。其语法如下：
Application.OnTime(EarliestTime, Procedure, LatestTime, Schedule)
OnTime的参数说明如表2-2所示。
█ 表2-2 OnTime参数列表
