Excel VBA范例大全
上QQ阅读APP看本书，新人免费读10天
设备和账号都新为新人
上一章目录下一章

第13章 其他应用

本章讲解一些与单元格或者区域数据运算无关的程序，但在工作中却有一定的实用性。

● 实例95发邮件及开启网址

● 实例96放大单元格数据

● 实例97产生不重复随机数

● 实例98将含有分隔符之数据转为下拉列表

● 实例99生成带圈之编号

● 实例100单元格动态显示时间

● 实例101根据指定最大值和最小值求所有数据之和

● 实例102根据勾股求弦长

● 实例103输入三边长求三角形面积

● 实例104指定时间出现“会议时间到”的提示

实例95 发邮件及开启网址

【技巧说明】 发邮件及开启网址。

【案例介绍】 在编写一个程序给用户使用时，为了体现作者与用户的互动，一般需要设定一个信息反馈的渠道。因此，让用户遇到问题时可以通过Excel程序访问指定网页或者向指定地址发送邮件就显得有必要了。

【案例实现】 参见以下步骤：

[1] 使用快捷键Alt+F11进入VBE（Visual Basic Editor）环境。

[2] 单击菜单【插入】\【模块】，打开模块代码窗口。

[3] 在右边代码窗口输入以下代码：

Sub发邮件及开启网址()
    If MsgBox("现在发送邮件!"&Chr(10)&"选是发送，选否退出！",vbYesNo+64,
        "邮件")=vbYes Then
    ActiveWorkbook.FollowHyperlink "maiLTo:andy_qc@163.com"
    End If
    If MsgBox("现在登录163网页!" & Chr(10) & "选是登录，选否退出！", vbYesNo
    ActiveWorkbook.FollowHyperlink "http://news.163.com"
    End If
End Sub

+64, "网页")=vbYes Then

[4] 关闭VBE窗口返回到工作表。

[5] 利用快捷键Alt+F8调出运行宏窗口，然后单击“执行”按钮，程序将先后弹出两个对话框，选“是”则发送邮件并开启网页，如图2.117所示。

图2.117 发送邮件及登录网址对话框

提示

本实例参见光盘样本：..\第2部分\实例95.xlsm。

【相关知识说明】

FollowHyperlink：如果已经下载指定文档，则显示缓冲区中的该文档。否则，本方法对指定超链接进行处理以下载目标文档，然后将该文档在适当的应用程序中显示出来。

用FollowHyperlink方法链接网址时只需要FollowHyperlink后跟引号引上的网址即可；而用FollowHyperlink方法启动邮件，则需要在邮件地址前加“mailto:”才行。

实例96 放大单元格数据

【技巧说明】 将单元格数据放大指定倍数显示。

【案例介绍】 选择工作表中任意单元格或者区域，将选区中的数据放大3倍显示。

【案例实现】 参见以下步骤：

[1] 使用快捷键Alt+F11进入VBE（Visual Basic Editor）环境。

[2] 使用快捷键Ctrl+R，显示工程资源管理器。

[3] 双击左边列表中的“Sheet1”，打开工作表代码窗口。

[4] 在右边代码窗口输入以下代码：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Application.EnableEvents=False      '禁用事件
  On Error Resume Next                '出错时继续执行
    ActiveSheet.DrawingObjects.Delete    '删除产生的对象
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                                        '将选项复制为图片
    Target.Cells(1, 1).Offset(0, 2).Select           '将光标移到后两列
    ActiveSheet.Pictures.Paste.Select
    With Selection.ShapeRange
      .ScaleWidth 2, msoFalse, msoScaleFromTopLeft
                                  '将图片增大三倍，可以自己调整
      .ScaleHeight 2, msoFalse, msoScaleFromTopLeft
      .Fill.ForeColor.SchemeColor=3           '设置前景填充色
    End With
    Target.Activate                           '激活单元格
    Application.EnableEvents=True               '恢复事件
End Sub

[5] 关闭VBE窗口返回到工作表。

[6] 在“Sheet1”工作表中选择空白单元格，程序将忽略；选择非空单元格后则放大3倍显示，如图2.118所示。

图2.118 放大单元格数据

提示

本实例参见光盘样本：..\第2部分\实例96.xlsm。

【相关知识说明】

（1）DrawingObjects：工作表中的图形对象。

（2）WorksheetFunction.CountA：计算非空单元格及参数列表中值的个数。

（3）Selection.CopyPicture：将所选对象作为图片复制到剪贴板。

实例97 产生不重复随机数

【技巧说明】 产生不重复随机数。

【案例介绍】 制作抽奖号码等时需要随机数，且所有数据不能重复，本例将产生1~10000之间的不重复随机数据。

【案例实现】 参见以下步骤：

[1] 使用快捷键Alt+F11进入VBE（Visual Basic Editor）环境。

[2] 单击菜单【插入】\【模块】，打开模块代码窗口。

[3] 在右边代码窗口输入以下代码：

Sub不重复随机数()
  Dim arr1&(1 To 10000, 1 To 1), arr2(1 To 10000) As Boolean, k&, m&
  [a:a].Clear
  Randomize
  m=0
  Do While m < 10000
    k=Int(10000 * Rnd)+1
    If Not arr2(k) Then
      m=m+1
      arr1(m, 1)=k
      arr2(k)=True
    End If
  Loop
  [a:a]=arr1
  [a:a].NumberFormatLocal="0000"
 End Sub

[4] 关闭VBE窗口返回到工作表。

[5] 利用快捷键Alt+F8调出运行宏窗口，然后单击“执行”按钮，A列将产生不重复随机数据。可以利用以下数组公式来验证：

=SUM(1/COUNTIF(A1:A10000,A1:A10000))

此公式计算A1∶A10000的不重复数据个数，如果结果等于10000，则表示结果正确。

提示

本实例参见光盘样本：..\第2部分\实例97.xlsm。

【相关知识说明】

Randomize：初始化随机数生成器。

实例98 将含有分隔符之数据转为下拉列表

【技巧说明】 将含有分隔符之数据转为下拉列表。

【案例介绍】 单元格中同类型数据用“/”符号分隔，现需转换格式为下拉列表，以分隔符为基准，每一单元产生一个下拉项目。

【案例实现】 参见以下步骤：

[1] 使用快捷键Alt+F11进入VBE（Visual Basic Editor）环境。

[2] 单击菜单【插入】\【模块】，打开模块代码窗口。

[3] 在右边代码窗口输入以下代码：

Sub将有分隔样式之数据转为下拉列表()
    For i=3 To [b1048576].End(xlUp).Row
    x=Replace(Cells(i, 2), "/", ",") '将分隔符/替换为逗号
    Cells(i, 3).Clear               '清除第三列所有数据信息
    With Cells(i, 3).Validation      '为第三列添加数据有效性下拉列表
      .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=_
      xlBetween, Formula1:=x
    End With
    Next i
End Sub

[4] 关闭VBE窗口返回到工作表。

[5] 利用快捷键Alt+F8调出运行宏窗口，然后单击“执行”按钮，C列将产生下拉列表，如图2.119。

图2.119 转换后的下拉列表

提示

本实例参见光盘样本：..\第2部分\实例98.xlsm。

【相关知识说明】

Validation：代表工作表区域的数据有效性规则。将其Type参数设为xlValidateList可以产生下拉列表。

实例99 生成带圈之编号

【技巧说明】 生成带圈之编号。

【案例介绍】 Excel自带1~10的带圈字符，若需要超过10的带圈字符时只好手工操作，在椭圆形中添加数字。本例将使用代码批量产生带圈数字编号。

【案例实现】 参见以下步骤：

[1] 使用快捷键Alt+F11进入VBE（Visual Basic Editor）环境。

[2] 单击菜单【插入】\【模块】，打开模块代码窗口。

[3] 在右边代码窗口输入以下代码：

Sub带圈编号()
Dim row1 As Integer, row2 As Integer, fontsize As Byte, ZT As String
On Error GoTo err
If Selection.Cells.Count=1 Then
row1=InputBox("请输入填充起始号", "序号", 1)
row2=InputBox("请输入填充终止号", "序号", 10)
fontsize=InputBox("请输入序号之字体大小", "字号", 10)
ZT=InputBox("请输入序号之字体" & Chr(10) & "若单元格较小，请用宋体！", "字体",
    "Impact")
Application.ScreenUpdating=False
For i=row1 To row2
    ActiveSheet.Shapes.AddShape(msoShapeOval, Selection.Left,
        Selection.Top, Selection.Width, Selection.Height).Select
    Selection.Characters.Text=i
    With Selection.Characters(Start:=1, Length:=Len(i)).Font
      .Name=ZT
      .Size=fontsize
    End With
    With Selection
      .ShapeRange.Fill.Visible=False
      .Font.ColorIndex=1
      .ShapeRange.Line.ForeColor.SchemeColor=8
      .ShapeRange.Line.Visible=msoTrue
      .HorizontalAlignment=xlCenter
      .VerticalAlignment=xlCenter
      .Orientation=xlHorizontal
    End With
    ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
    Next
Else
MsgBox "请选择单个单元格再启用本程式", vbDefaultButton1+64, "提示"
End If
Application.ScreenUpdating=True
Exit Sub
err:
MsgBox "请选择单个单元格再启用本程式", vbDefaultButton1+64, "提示"
End Sub

[4] 关闭VBE窗口返回到工作表。

[5] 将光标定位于需要产生编号的第一个单元格，利用快捷键Alt+F8调出运行宏窗口，然后单击“执行”按钮，将分别弹出输入起始号、终止号、字体大小及选择字体之对话框，如图2.120至图2.123所示。逐个输入后，目标列将产生带圈编号，如图2.124所示。

图2.120 输入起始号

图2.121 输入终止号

图2.122 输入字体大小

图2.123 输入字体

图2.124 代码生成的带圈编号

提示

本实例参见光盘样本：..\第2部分\实例99.xlsm。

【相关知识说明】

（1）Shapes.AddShape：返回一个Shape对象，该对象表示工作表中的新自选形状，一般用它来生成新的自选图形。

（2）Characters：代表包含文本的对象中的字符。本例中表示椭圆中的数字。

（3）Selection.Orientation=xlHorizontal：表示水平方向放置。

实例100 单元格动态显示时间

【技巧说明】 在单元格中动态显示时间。

【案例介绍】 在一个单元格中显示时间，且与系统时间同步。

【案例实现】 参见以下步骤：

[1] 使用快捷键Alt+F11进入VBE（Visual Basic Editor）环境。

[2] 单击菜单【插入】\【模块】，打开模块代码窗口。

[3] 在右边代码窗口输入以下代码：

Sub与系统时间同步()
  [a1]=WorksheetFunction.Text(Now(), "yyyy-mm-dd h:mm:ss")
  Application.OnTime Now+TimeValue("00:00:01"), "与系统时间同步"
End Sub

[4] 关闭VBE窗口返回到工作表。

[5] 利用快捷键Alt+F8调出运行宏窗口，然后单击“执行”按钮，单元格A1中立即产生动态的时间，且与任务栏时间同步，如图2.125所示。

图2.125 单元格中动态显示时间

提示

本实例参见光盘样本：..\第2部分\实例100.xlsm。

【相关知识说明】

（1）Now()：表示计算机控制面板中设定的当前时间。

（2）Application.OnTime：安排一个过程在将来的特定时间运行（既可以是具体指定的某个时间，也可以是指定的一段时间之后）。语法为：表达式.OnTime(EarliestTime, Procedure, LatestTime, Schedule)。OnTime的各个参数含义见表2.7。

表2.7 OnTime参数表

（3）从表2.7中可以看到，若要停止本例程序的继续执行，则将OnTime的Schedule参数设为False。参见以下代码：

Sub停止()
  Application.OnTime Now+TimeValue("00:00:01"),"与系统时间同步",,False
End Sub

实例101 根据指定最大值和最小值求所有数据之和

【技巧说明】 根据指定最大值和最小值求所有整数之和。

【案例介绍】 输入一个最大值和一个最小值，返回从最小值到最大值之间的整数序列之和。

【案例实现】 参见以下步骤：

[1] 使用快捷键Alt+F11进入VBE（Visual Basic Editor）环境。

[2] 单击菜单【插入】\【模块】，打开模块代码窗口。

[3] 在右边代码窗口输入以下代码：

Sub求范围之和()
    Dim iMin As Long, iMax As Long, i As Long, temp As Long
    iMin=Application.InputBox("请输入最小值", "起始值", "0", Type:=1)
    iMax=Application.InputBox("请输入最大值", "终止值", "100", Type:=1)
    For i=iMin To iMax
    temp=temp+i
    Next
    MsgBox temp
End Sub

[4] 关闭VBE窗口返回到工作表。

[5] 利用快捷键Alt+F8调出运行宏窗口，然后单击“执行”按钮，程序将提示输入最小值和最大值，如图2.126所示。

[6] 输入起止值后，将返回两个数据之间整数之和，如图2.127所示。

图2.126 输入最小值和最大值

图2.127 最后结果

提示

本实例参见光盘样本：..\第2部分\实例101.xlsm。

实例102 根据勾股定理求弦长

【技巧说明】 根据勾长和股长返回弦长。

【案例介绍】 勾股定理又叫做毕氏定理：在一个直角三角形中，斜边边长的平方等于两条直角边边长平方之和。本例输入勾和股计算弦长。

【案例实现】 参见以下步骤：

[1] 使用快捷键Alt+F11进入VBE（Visual Basic Editor）环境。

[2] 单击菜单【插入】\【模块】，打开模块代码窗口。

[3] 在右边代码窗口输入以下代码：

Sub利用勾股定理求弦长()
    Dim勾As Integer, 股As Integer
    勾=Application.InputBox("勾", "数据", 3, 10, 10, , , 1)
    股=Application.InputBox("股", "数据", 4, 10, 10, , , 1)
    If勾 <=0 Or股 <=0 Then MsgBox "勾和股必须大于0！": Exit Sub
    MsgBox "弦为:" & WorksheetFunction.Power(勾 ^ 2+股 ^ 2, 0.5)
End Sub

[4] 关闭VBE窗口返回到工作表。

[5] 利用快捷键Alt+F8调出运行宏窗口，然后单击“执行”按钮，程序将提示输入勾长和股长，如图2.128所示。

[6] 输入勾股后，将返回弦长，如图2.129所示。

图2.128 输入勾长和股长

图2.129 最后结果弦长

提示

本实例参见光盘样本：..\第2部分\实例102.xlsm。

【相关知识说明】

（1）WorksheetFunction.Power：返回某数的乘幂结果。

（2）^：表示N次方。A^2即表示A的2次方，B^10即为B的10次方。

实例103 输入三边长求三角形面积

【技巧说明】 输入三边长求三角形面积。

【案例介绍】 数学中经常遇到根据三边长求三角形面积的问题，利用公式手工计算较复杂，本例可以输入三边后瞬间计算面积。

【案例实现】 参见以下步骤：

[1] 使用快捷键Alt+F11进入VBE（Visual Basic Editor）环境。

[2] 单击菜单【插入】\【模块】，打开模块代码窗口。

[3] 在右边代码窗口输入以下代码：

Sub输入三边长求三角形面积()
    Dim A, B, C, temp
    A=Application.InputBox("请输入边一长度:", "数据", 3, 10, 10, , , 1)
    B=Application.InputBox("请输入边二长度:", "数据", 4, 10, 10, , , 1)
    C=Application.InputBox("请输入边三长度:", "数据", 5, 10, 10, , , 1)
    temp=(A+B+C) / 2
    If A <=0 Or B <=0 Or C <=0 Then MsgBox "所有边长都必须大于0": Exit Sub
    If A <=Abs(B-C) Or B <=Abs(A-C) Or C <=Abs(A-B) Then MsgBox
        "两边之差不能小于第三边": Exit Sub
    MsgBox "面积为:" & WorksheetFunction.Power(temp * (temp-A) * (temp-B)
    * (temp-C), 0.5)
End Sub

[4] 关闭VBE窗口返回到工作表。

[5] 利用快捷键Alt+F8调出运行宏窗口，然后单击“执行”按钮，程序将提示输入三边长度，如图2.130所示。

[6] 输入边长后，将返回三角形面积，如图2.131所示。

图2.130 输入三边长度

图2.131 返回三角形面积

提示

1.本实例参见光盘样本：..\第2部分\实例103.xlsm。

2.三角形三边的特点是每边都大于0且两边之差大于第三边，故程序中需进行限制。

实例104 指定时间出现“会议时间到”的提示

【技巧说明】 让Excel在指定时间提示自己“会议时间到”。

【案例介绍】 用Excel可以做一些日程表，让Excel在设定时间里弹出相应提示。

【案例实现】 参见以下步骤：

[1] 使用快捷键Alt+F11进入VBE（Visual Basic Editor）环境。

[2] 单击菜单【插入】\【模块】，打开模块代码窗口。

[3] 在右边代码窗口输入以下代码：

Sub提示()
MsgBox "会议时间到，请早做准备！", 64, "提示"
End Sub

[4] 使用快捷键Ctrl+R，显示工程资源管理器。

[5] 双击左边“Thisworkbook”，在右边代码窗口输入以下代码：

Private Sub Workbook_Open()
    Application.OnTime #09:00:00 AM#, "提示"
End Sub

[6] 关闭工作簿再开启，到了每天9∶00时自动弹出提示，如图2.132所示。

图2.132 信息提示

提示

本实例参见光盘样本：..\第2部分\实例104.xlsm。

【相关知识说明】

（1）Private Sub Workbook_Open()：工作簿事件的一种，可以使程序在开启工作簿时自动运行。

（2）#09:00:00 AM#：日期/时间表示法，需要前后各有一个#符号，其中AM表示上午，PM表示下午。

上一章目录下一章