[原创] 《Excel 2010 VBA编程与实践》内容选登

andysky

疑难 7 如何开发完善的程序？

编写代码解决一个工作问题是很简单的，但是如何让程序完善，可以适应所有环境，且通用、兼容、可防错，这是一门相当复杂的学问。那么如何开发一个完善的程序？程序开发常会有什么错误及如何防范呢？

解决方案：

通过常规思路开发一段程序完成基本需求。然后查找存在的问题并进行完善；再对新的过程审核是否有新问题，继续完善，直到没有任何问题。

操作方法

步骤1 以让用户从对话框录入一个值，并对该值开平方后写入活动单元格。根据题目需求，编写以下代码：

Sub 获取平方根1()

Dim Value As Long

Value = InputBox("请输入数值：", "待开方之数值", 0)

ActiveCell.Value = Sqr(Value)

End Sub

步骤2 执行以上过程，并输入100或者789、123.455等等数据测试，可以发现实现了需求的功能。然而如果用户在对话框上单击“取消”按钮，那么程序会出错。修改代码如下：

Sub 获取平方根2()'解决按“取消”键问题

Dim Value As Variant
       Value = InputBox("请输入数值：", "待开方之数值", 0)

If Len(Value) = 0 Then Exit Sub

ActiveCell.Value = Sqr(Value)

End Sub

步骤3 再执行程序验证，按下“取消”键后程序会自动退出，具有了防错功能。然而输入一个负数，程序仍然要出错。继续改进代码：

Sub 获取平方根3()'解决负数问题

Dim Value

Value = InputBox("请输入数值：", "待开方之数值", 0)

If Len(Value) = 0 Then Exit Sub

If Not Value < 0 Then ActiveCell.Value = Sqr(Value) Else MsgBox "不能小于0"

End Sub

步骤4 当输入负数后，程序会提示用户，然后退出。但如果用户录入文本，程序仍然要出错，所以再次对代码做优化：

Sub 获取平方根4()'解决文字问题

Dim Value

Value = InputBox("请输入数值：", "待开方之数值", 0)

If Len(Value) = 0 Then Exit Sub

If VBA.IsNumeric(Value) Then

If Not Value < 0 Then ActiveCell.Value = Sqr(Value) Else MsgBox "不能小于0"

Else

MsgBox "不能输入文本", 64, "提示"

End If

End Sub

步骤5 如果输入文本，程序具有了识别并警告用户的功能。然而，活动表是图表时，执行程序仍然会出错。完善的程序需要处理所有意外，那么程序可以如下改进：

Sub 获取平方根5()'解决图表问题

Dim Value

If TypeName(ActiveSheet) = "Chart" Then MsgBox "不要选择图表": Exit Sub

Value = InputBox("请输入数值：", "待开方之数值", 0)

If Len(Value) = 0 Then Exit Sub

If VBA.IsNumeric(Value) Then

If Not Value < 0 Then ActiveCell.Value = Sqr(Value) Else MsgBox "不能小于0"

Else

MsgBox "不能输入文本", 64, "提示"

End If

End Sub

步骤6  如果工作表被保护状态下执行以上程序仍然会出错，继续完善代码：

Sub 获取平方根6()'解决工作表保护问题

Dim Value

If TypeName(ActiveSheet) = "Chart" Then MsgBox "不要选择图表": Exit Sub

If ActiveSheet.ProtectContents Then MsgBox "工作表已保护": Exit Sub

Value = InputBox("请输入数值：", "待开方之数值", 0)

If Len(Value) = 0 Then Exit Sub

If VBA.IsNumeric(Value) Then

If Not Value < 0 Then ActiveCell.Value = Sqr(Value) Else MsgBox "不能小于0"

Else

MsgBox "不能输入文本", 64, "提示"

End If

End Sub

步骤7 如果活动单元格处理数组区域之间，程序仍然会产生错误。所以最后将代码优化为：

Sub 获取平方根7()'解决数组区域问题

Dim Value

If TypeName(ActiveSheet) = "Chart" Then MsgBox "不要选择图表": Exit Sub

If ActiveSheet.ProtectContents Then MsgBox "工作表已保护": Exit Sub

Value = InputBox("请输入数值：", "待开方之数值", 0)

If Len(Value) = 0 Then Exit Sub

If VBA.IsNumeric(Value) Then

On Error Resume Next

Debug.Print ActiveCell.CurrentArray

If Err = 0 Then MsgBox "请不要选择数组区域": Exit Sub

If Not Value < 0 Then ActiveCell.Value = Sqr(Value) Else MsgBox "不能小于0"

Else

MsgBox "不能输入文本", 64, "提示"

End If

End Sub

原理分析

编程的基本条件是准确性。然而程序除了准确以外，还必须具备防错、通用的功能，否则代码在当前状态下正确执行，环境稍加变化就出现错误，那么会增加很多维护成本。一个好的程序应该尽量通用于所有状况，而本例正是通过一个典范来展示程序的完善过程，让读者对程序可能出现的错误进行了解，并提供所有错误的解决之道。在实际工作中，都应该严格按此思路编写代码，提升程序的准确性、纠错性，同时也减少维护成本。

知识扩展

区域数组公式是同时存在于多个连续单元格中的带有“{}”标志的公式，将它录入到工作表后就将占据一个区域，而非一个单元格，该区域即为数组区域。它的特性是不能单独修改区域中任意一个单元格，如果代码修改其中一个单元格，程序会中断。

本例中也可以利用“On Error Resume Next”一次解决所有问题，其代码如下。不过如果执行程序后得不到结果，就无法知道出错的原因。

Sub 获取平方根8()'解决所有问题
       On Error Resume Next

ActiveCell.Value = Sqr(Application.InputBox("请输入数值：", "开平方", 0, , , , , 1))

End Sub

注意：本书中编程的主题是准确性、效率、防错性和兼容性，代码一定要对所有错误进行防范，确保程序通用。然而为了节约篇幅，让书中展现更多内容，所以尽量减少重复代码，对于工作表是否保护、当前表是否图表以及活动单元格是否在数组区域之间就不再每个案例都进行判断，只对其它出错的可能性进行防错。但读者在实际工作中应该全面进行防错。

疑难7.rar (10.43 KB, 下载次数: 185)

2011-5-14 10:04 上传

点击文件名下载附件

《Excel 2010 VBA编程与实践》PDF.rar (490.75 KB, 下载次数: 610)

2011-5-14 10:04 上传

点击文件名下载附件

andysky

疑难 26 如何在输入时逐步查找？

工作表中存放某班级的成绩表,如何实现录入一个字符即进行查找，然后逐步缩小范围。例如输入“黄”，提罗列出姓名中包括“黄”的所有人员姓名，继续录入“天”，则罗列出所有包括“黄天”的姓名。

解决方案：

创建一个窗体，并在窗体中绘制一个文字框供用户录入查询字符串，再绘制一个ListView控件用于显示查询结果。为了让录入时实现逐步查询，需要使用文字框的KeyUp事件，从而每录入一字符即通过Find进行模糊查找，并将找到所有信息罗列在ListView控件中。其中ListView控件默认不显示在工具箱中，需要通过附件控件调用它。

操作方法

步骤1 按〈Alt+F11〉组合键打开VBE窗口；

步骤2 单击菜单〈插入〉→“窗体”，从而产生一个默认名称为“UserForm1”的窗体；

步骤3 单击窗体，此时会自动出现一个工具箱，其外观如图26&#8209;1所示。如果没有出现则可以单击菜单“视图”→“工具箱”来调出工具箱；

步骤4 单击工具箱中的“标签”控件，并在窗体左上角拖放（按下左键拖动，然后松开鼠标），从而在窗体中绘制一个标签；

步骤5 如果默认状态没有显示属性对话框，可以按〈F4〉键调出“属性”窗口，并找到“Caption”属性，将其值修改为“请输入姓名:”；

步骤6 单击工具箱中的“文字框”控件，并在窗体中上部拖放绘制一个文字框；

步骤7 在工具箱中间的空白区单击右键，从弹出的快捷菜单中选择“附加控件”，并在打开的“附加控件”对话框中找到“Microsoft ListView Control, version 6.0”并将其选中，再单击“确定”按钮。“附件控件”对话框见图26&#8209;2所示：

图 26&#8209;1默认状态的工具箱

图 26&#8209;2附加ListView控件

步骤7 单击工具箱中的“ListView”控件，并在窗体中拖放，拖放时适当控制其大小，使ListView控件在不覆盖文字框的前提下可以填充整个窗体；

步骤8 双击窗体任意位置进入窗体的代码窗口，将自动产生的代码删除，然后录入以下代码：

'启动窗体时执行，功能是对窗体中的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

步骤9 单击菜单“插入”→“模块”，并在模块中录入以下代码：

Sub 查询()

UserForm1.Show 0

End Sub

步骤10 返回工作表，单击功能区的“开发工具”选项卡→“插入”→“按钮（窗体控件）”，并在工作表中拖动，从而绘制一个命令按钮，且将其默认名称修改为“逐步查询”；

步骤11 在弹出的“宏”对话框中选择“查询”并单击“确定”按钮返回工作表。单击按钮弹出“逐步查询”窗体，此时窗体中显示空白。在文字框中录入“不”，“ListView”控件将会罗列出所有包含“不”的人员信息且窗体的高度刚好适应信息列表，见图26&#8209;3所示；

步骤12 继续录入“败”，则列表中显示所有包含“不败”的人员信息，同时自动调整高度使其美观，见图26&#8209;4所示：

      

  图 26&#8209;3 图 查询包括“不”的人员信息  

图 26&#8209;4 查询包括“不败”的人员信息

原理分析

文字框的KeyUp事件在按下任意键时触发事件，从而执行指定的SUB过程，适用于逐步运行程序的需求。通常还用它来检查输入的字符是否符合要求，例如是否录入有效数值或者长度是否超过需求。

为了让ListView控件可以多列显示多个信息，需要对“ListItems.Add()”添加的项目追加子项目，即SubItems(1)、SubItems(2)的赋值。

让ListView控件高度具有自动适应信息量的原理是：ListView控件的字体大小乘以显示行数，再加标题、边框所占用的高度，通常用20即可。窗体的高度也随ListView控件相应变化，可以更美观。

知识扩展

在没有自定义窗体时，工具箱不会显示出来，在选择窗体时通常可以自动显示；

工具箱中默认包括12个控件（第一个不算），需要使用其它控件时必须手工附加控件。比较有价值的附件控件还有很多，例如Web控件、Flash控件、ImageList控件和Dialog控件、Chart控件等等。

显示窗体可以用代码“UserForm1.Show 0”调用，也可以光标定位于代码中的任意位置并按〈F5〉键显示窗体。通常在工作表中创建一个按钮配合命令调用更方便。也可以生成菜单来调用窗体，菜单的生成方式请参阅本书的第十章。

提示：“ListView”控件存在版本问题，版本不同打开时可能出错，也就是说有可能我做的表您无法打开。所以最好的办法是按以上步骤自己设计，而不是使用我的附件

没有办法像书中那样排版美观，谅解。

[ 本帖最后由 andysky 于 2011-5-14 10:17 编辑 ]

andysky

疑难 29 如何查找所有”#”并标为上标？

图 29&#8209;1中的所有“#”符号表示机台号，如何可以查找到所有“#”号并上标显示？

  

图 29&#8209;1 生产表

解决方案：

对Range.Find方法查找每个包含“#”的单元格，并将其中的“#”字符设置字体属性——Superscript，表示上标显示。为了体现程序的通用性，允许用户自定义需要上标显示的字符，以及让程序对单元格逐个字符检查，将每一个“#”都上标显示。

操作方法

步骤1 确定活动工作表为“生产表”，按<Alt+F11>组合键打开VBE窗口；

步骤2 单击菜单“插入”→“模块”，并录入以下代码：

Sub 替换指字符标示为上标()

Dim rng As Range, i As Integer, FirstSrt 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

步骤3 光标置于代码中任意位置，并按<F5>键执行，表中所有表示机台号的“#”都自动上标显示。

  

图 29&#8209;2 将#标示为上标

原理分析

对Range.Find方法的“LookAt”参数设置为“xlPart”可以实现模糊查找，将包括“#”的单元格逐个找到。而Characters属性可以定位于单元格中部分字符串，配合MID$函数可以逐个字符检查，并对符合条件的字符标示为上标。

知识扩展

Superscript表示上标，Subscript表示下标字符。但上标和下标都只对文本生效，如果是数值，需要将其数字格式转换成文本后再执行标示。

如果需要对“M2”中的“2”进行上标，则可以改用以下代码：

Sub 将M后面的2标示为上标()
          Dim rng As Range, i As Integer, FirstSrt 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" 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

andysky

疑难 24 如何查找不及格学生姓名并突出显示？

图 24&#8209;1中的工作表包含某年级所有学生的语文成绩，如何将不及格的所有学生姓名所在单元格背景设为黄色？需要忽略未参考人员，程序需要具备通用性。

图 24&#8209;1 语文成绩表

解决方案：

Find方法无法使用比较运算符进行按范围查找，只能采用For...Next循环或者Loop循环语句遍历C列成绩区域，对每个非空单元格进行数值判断。如果符合条件“不及格”则逐一合并所有单元格到同一个Range对象变量中，最后将该变量所代表的区域进行背景着色。

操作方法

步骤1　确定活动工作表为“语文成绩”，按<Alt+F11>组合键打开VBE窗口；

步骤2　单击菜单“插入”→“模块”，并录入以下代码：

Sub 查询并标示()
       Dim rng As Range, RngTemp As Range, cell As Range'声明三个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

步骤2　返回工作表，单击功能区的“开发工具”选项卡→“宏”按钮，并执行过程“查询并标示”。程序执行结果如图24&#8209;2所示：

图 24&#8209;2执行结果

原理分析

本例中涉及两个重要的知识点：让程序自动适应查询的目标区域，以及合并已找到的多个单元格。

其中获取待查询的目标区域使用了“Range([c2], Cells(Rows.Count, "C").End(xlUp))”语句，表示C2到C列最后一个非空单元格之间的整个区域。它具有延展性，即可以提升程序的通用性能，可以随C列数据的增减变化而自动适应。其通用性主要体现在两个方面：首先是利用Cells(Rows.Count, "C")获取C列最后一个单元格，使程序可以在Excel 2003早期版本和Excel 2010都能正确执行，防止出错。而采用“Range(“C65536”)”或者“Range(“C1048576”)”则兼容性不足；其次，配合End(xlUp)属性取C列最后一个非空单元格。它可以让程序自动适应成绩表的增减变化，从而提升程序的适应性能。远远优于Range(“C2:C21”)这种硬性定位区域的思路

合并已找到的多个单元格则主要是为了提升程序的性能。本例中采用Union方法将所有找到的符合条件的单元格合并为一个Range对象，最后对这个对象进行着色操作，即仅仅需要一次着色操作。如果每找到一个目标就进行着色则在效率上会有偏差。

知识扩展

For Each...Next 语句表示针对一个数组或集合中的每个元素，重复执行一组语句。其语法如下：

For Each 变量 In 集合

一条或多条语句

[Exit For]

一条或多条语句

Next [变量]

其中Exit For是可选参数，用于中途退出循环。

本例也可以采用数组来执行，当工作表中数据较多时，执行效率会有明显的提升。代码如下：

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

[ 本帖最后由 andysky 于 2011-5-14 10:14 编辑 ]

andysky

疑难 32 可以创建一个工具栏来方便查找吗？

如何实现工具栏查找?即创建一个可以输入文本的工具栏,在工具栏中输入字符后回车即可对工作表中对应的单元格进行查找,并报告所有找到的单元格地址,以及选中所有单元格。

解决方案：

利用CommandBars.Controls.Add方法在工具栏创建新工具按钮，包括一个msoControlButton和一个msoControlEdit对象，其中msoControlEdit对象可以输入字符。而通过对按钮指定“OnAction”参数的方式可以实现msoControlEdit对象中输入字符并回车后可以调用一个查找程序。该程序调用Range.Find方法对工作表中查找用户录入的字符，并选中所有符合条件的单元格。

操作方法

步骤1 按<Alt+F11>组合键打开VBE窗口；

步骤2 单击菜单“插入”→“模块”，并录入以下代码：

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

步骤3 光标置于“auto_open”过程的代码中，并按<F5>键执行，那么在工具栏将产生两个自定义按钮。不过在Excel 2010和2003中显示方式不同，分别见图
32&#8209;1和图32&#8209;2所示；

   
  

                                       

图 32&#8209;1 Excel 2010菜单样式

  

  图 32&#8209;2 Excel 2003菜单样式

步骤4 返回工作表中，在刚才创建的文字框控件中录入“丽”并按下回车键，工作表中所有包括“丽”的单元格都会呈选中状态，同时提示所有单元格地址，见图32&#8209;3所示：

  

图 32&#8209;3 查找所有包括“丽”的单元格

原理分析

CommandBars.Controls.Add方法创建的自定义工具栏可以通过“OnAction”参数调用一个过程，那么将它指向一个具有查找功能的SUB过程即可实现查找。

设置lookat参数实现模糊查找

本文需要模糊查找，Range.Find的lookat参数需要设定为“xlPart”。如果有多个单元格符合条件，利用Union进行合并，最后选择该区域。

知识扩展

CommandBars("Formatting")表示格式工具栏，本例中在格式工具栏最末处添加两个新按钮。如果需要创建在最前面，可以再加一个参数“before:=1”，表示新按钮拉于第一个按钮之前。不过该排序对Excel 2003有影响，在Excel 2010中感觉不到变化。

也可以将对话框改为状态栏显示。Msgbox语句改为赋值给Application.StatusBar。

[ 本帖最后由 andysky 于 2011-5-14 11:51 编辑 ]

ctp_119

这本书，我买了，学习不错！支持！

Cellfarmer

谢谢，已订购此书。

andysky

疑难 35如何查找成绩并分批发邮件？

图 35&#8209;1为某班成绩及考生邮件地址,现需要将成绩利用邮件分别发送到各学生账号中,可以使用VBA完成吗?

图 35&#8209;1成绩表

解决方案：

API函数ShellExecute可以调用当前默认的邮件程序，配合For...Next循环可以将成绩逐个发向指定的邮箱。

操作方法

步骤1 确定活动工作表为“成绩表”，按<Alt+F11>组合键打开VBE窗口；

步骤2 单击菜单“插入”→“模块”，并录入以下代码：

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

步骤3 光标置于代码中任意位置，并按<F5>键执行，将弹出多个图35&#8209;2所示的窗口，将每一个考生的姓名和成绩都发送到对应的邮箱中；

图 35&#8209;2向第一个学生发送邮件

原理分析

ShellExecute函数可以调用Windows默认的邮件程序，且可以指定收件人邮箱地址、主题和正文。相对于其它仅仅调用Outlook的VBA程序，ShellExecute函数的优越性在于可以调用多种不同的邮件程序，默认是什么邮件程序就能调用什么程序。

知识扩展

VBA中发编写邮件正文时的换行符的表示法

ShellExecute函数调用邮件程序时，正文中换行不用chr(10)或者vbCrLf，而是“%0A”。每插入一个“%0A”换一行显示。

如果不需要将成绩分发，而是一次性将所有成绩发给所有人，同样可以利用ShellExecute函数实现。完整代码如下：

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

lgcmeli

谢谢罗版分享。这书我已经收购了。

andysky

疑难 38
在窗体中罗列每月产量冠军名单？
图 38&#8209;1中包含了多个月的生产数据。如何实现查找每月的产量冠军并同时显示在窗体列表中？


图 38&#8209;1 产量表
解决方案：
创建一个窗体，在窗体中添加一个列表框。利用公式“=MATCH(MAX(D2:D21),D2:D21,)”获取每个工作表中生产冠军的所有信息，然后配合For...Next循环找出每个月的生产冠军，并导入到数组中。最后将数组一次性赋值给窗体中列表框的List属性。


操作方法

步骤1 按<Alt+F11>组合键打开VBE窗口；
步骤2 单击菜单“插入”→“用户窗体”，并在属性窗口中将窗体的“Caption”属性修改为“每月产量冠军”；将工具箱中的列表框拖到窗体中，且调整窗体和列表框的大小，使其与图38&#8209;2一致；
步骤4 双击窗体进行窗体代码窗口，将自动产生的代码清除，然后重新录入以下代码：

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

步骤5 单击菜单“插入”→“模块”，并在模块中录入以下代码：

Sub 多表查找()
UserForm1.Show 0
End Sub

步骤5 执行过程“多表查找”，将会弹出图
38&#8209;3所示窗体，罗列出每月的产量冠军：
　
图 38&#8209;2

窗体中创建列表框


图 38&#8209;3

在窗体中罗列所有产量冠军
原理分析

本案例中有两个亮点：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)
提示：学习案例目的在于学习思路，而不是案例本身。能将案例的思路用到工作表才是上策，案例本身是否与自己的工作一样并不重要。

[ 本帖最后由 andysky 于 2011-5-14 10:32 编辑 ]