VBA程序设计用例：程序流程图及程序代码
vba简单编程案列
以下是一个简单的VBA编程案例，用于在Excel中创建一个简单的计算器程序。
该程序将接受用户输入的数字和运算符，并返回结果。
```vbaSub Calculator()Dim num1 As DoubleDim num2 As DoubleDim operator As StringDim result As Double' 获取用户输入num1 = InputBox("请输入第一个数字")operator = InputBox("请输入运算符（+, -, *, /）")num2 = InputBox("请输入第二个数字")' 根据运算符进行计算Select Case operatorCase "+"result = num1 + num2Case "-"result = num1 - num2Case "*"result = num1 * num2Case "/"If num2 <> 0 Thenresult = num1 / num2ElseMsgBox "除数不能为零"Exit SubEnd IfCase ElseMsgBox "无效的运算符"Exit SubEnd Select' 显示结果MsgBox "结果：" & resultEnd Sub```这个程序首先通过`InputBox`函数获取用户输入的两个数字和一个运算符。
然后，使用`Select Case`语句根据运算符执行相应的计算，并显示结果。
如果用户输入了无效的运算符或除数为零，程序会显示一个错误消息。
这个简单的VBA编程案例可以帮助用户快速创建自己的计算器应用程序，并在Excel中进行基本的数值计算。
excelvba编程实例
excelvba编程实例Excel VBA编程实例：创建一个销售数据分析报告在这个Excel VBA编程实例中，我们将一步一步地回答如何创建一个销售数据分析报告。
这个报告将会根据数据表中的销售数据生成销售额、销售量和利润率的统计信息，并在一个新的工作表中进行展示。
第一步：准备数据首先，我们需要准备一个包含销售数据的数据表。
数据表应该包括列标题，如“产品名称”、“销售额”、“销售量”和“成本”。
在每一列下面，我们将填入相应的数据。
第二步：打开VBA编辑器要编写VBA代码，我们需要打开VBA编辑器。
在Excel中，可以通过按下ALT + F11来打开VBA编辑器。
第三步：创建一个新的模块在VBA编辑器中，我们需要创建一个新的模块来编写我们的代码。
在左侧的“项目资源管理器”窗口中，选择工作簿，然后右键单击并选择“插入”->“模块”。
第四步：编写VBA代码在新的模块中，我们可以开始编写VBA代码。
下面是一个简单的示例代码，用于生成销售数据分析报告：vbaSub CreateSalesReport()Dim wsData As WorksheetDim wsReport As WorksheetDim lastRow As LongDim i As Long' 设置相关工作表Set wsData = ThisWorkbook.Worksheets("数据表")Set wsReport =ThisWorkbook.Worksheets.Add(After:=wsData) = "销售报告"' 标题wsReport.Cells(1, 1) = "产品名称"wsReport.Cells(1, 2) = "销售额"wsReport.Cells(1, 3) = "销售量"wsReport.Cells(1, 4) = "利润率"' 数据lastRow = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row ' 获取数据表最后一行For i = 2 To lastRow ' 循环遍历数据表中的数据wsReport.Cells(i, 1) = wsData.Cells(i, 1)wsReport.Cells(i, 2) = wsData.Cells(i, 2)wsReport.Cells(i, 3) = wsData.Cells(i, 3)wsReport.Cells(i, 4).Formula = "=" & wsReport.Cells(i, 2) & "/" & wsReport.Cells(i, 3) ' 计算利润率Next i' 格式化wsReport.Columns("B:B").NumberFormat = "0.00" ' 设置销售额为货币格式wsReport.Columns("C:C").NumberFormat = "0" ' 设置销售量为整数格式wsReport.Columns("D:D").NumberFormat = "0.00" ' 设置利润率为百分比格式' 统计信息wsReport.Cells(lastRow + 2, 1) = "总计"wsReport.Cells(lastRow + 2, 2).Formula = "=SUM(B2:B" & lastRow & ")" ' 计算销售额总计wsReport.Cells(lastRow + 2, 3).Formula = "=SUM(C2:C" & lastRow & ")" ' 计算销售量总计wsReport.Cells(lastRow + 2, 4).Formula = "=AVERAGE(D2:D" & lastRow & ")" ' 计算平均利润率' 增加边框wsReport.Range("A1:D" & lastRow + 2).Borders.LineStyle = xlContinuous' 自动调整列宽wsReport.Columns.AutoFitEnd Sub第五步：执行VBA代码现在，我们可以执行我们编写的VBA代码。
VBA 编程常见实例
1、将excel汇总好的表，按字段拆分为多sheet的情况：如下图：代码如下：Sub cfs()Dim GSArr() As String '公司名称清单Dim Rca As Integer 'A列数据行数Dim i As IntegerDim Sn As StringSn = Rca = Columns("A:A").End(xlDown).Row ‘按第A列数据拆分，且第一行无合并单元格ReDim GSArr(1 To 1)GSArr(1) = Cells(2, 1)For i = 3 To RcaIf IsError(Application.Match(Cells(i, 1), GSArr, 0)) ThenReDim Preserve GSArr(1 To UBound(GSArr) + 1)GSArr(UBound(GSArr)) = Cells(i, 1)End IfNextIf ActiveSheet.AutoFilterMode = False ThenRows("1:1").AutoFilterElseIf ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllDataEnd IfFor i = 1 To UBound(GSArr)ActiveSheet.Cells.AutoFilter Field:=1, Criteria1:=GSArr(i)Sheets.Add After:=Sheets(Sheets.Count) = GSArr(i)Sheets(Sn).Cells.Copy ActiveSheet.CellsSheets(Sn).ActivateNextActiveSheet.Cells.AutoFilterEnd Sub2、将汇总的好的EXCEL表按字段拆分为多个工作薄代码如下：Sub CFGZB()Dim myRange As VariantDim myArrayDim titleRange As RangeDim title As StringDim columnNum As IntegermyRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)myArray = WorksheetFunction.Transpose(myRange)Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", Type:=8)title = titleRange.ValuecolumnNum = titleRange.ColumnApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseDim i&, Myr&, Arr, num&Dim d, kFor i = Sheets.Count To 1 Step -1If Sheets(i).Name <> "数据源" Then ‘待拆分的表sheet名为：数据源Sheets(i).DeleteEnd IfNext iSet d = CreateObject("Scripting.Dictionary")Myr = Worksheets("数据源").UsedRange.Rows.CountArr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))For i = 1 To UBound(Arr)d(Arr(i, 1)) = ""Nextk = d.keysFor i = 0 To UBound(k)Set conn = CreateObject("adodb.connection")conn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName‘2013版连接字符Sql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"Dim Nowbook As WorkbookSet Nowbook = Workbooks.AddWith NowbookWith .Sheets(1).Name = k(i)For num = 1 To UBound(myArray).Cells(1, num) = myArray(num, 1)Next num.Range("A2").CopyFromRecordset conn.Execute(Sql)End WithEnd WithThisWorkbook.ActivateSheets(1).Cells.SelectSelection.CopyWorkbooks().ActivateActiveSheet.Cells.SelectSelection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _SkipBlanks:=False, Transpose:=FalseApplication.CutCopyMode = FalseNowbook.SaveAs ThisWorkbook.Path & "\" & k(i)Nowbook.Close TrueSet Nowbook = NothingNext iconn.CloseSet conn = NothingApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub3、将含有多sheet的一个工作表，按sheet名拆分为工作表代码如下：Private Sub 分拆工作表()Dim sht As WorksheetDim MyBook As WorkbookSet MyBook = ActiveWorkbookFor Each sht In MyBook.Sheetssht.CopyActiveWorkbook.SaveAs Filename:=MyBook.Path & "\" & , FileFormat:=xlNormal '将工作簿另存为EXCEL默认格式ActiveWorkbook.CloseNextMsgBox "文件已经被分拆完毕!"End Sub4,、将多个工作薄合并为一个多sheet的工作薄代码如下：Sub Books2Sheets()'定义对话框变量Dim fd As FileDialogSet fd=Application.FileDialog(msoFileDialogFilePicker)'新建一个工作簿Dim newwb As WorkbookSet newwb=Workbooks.AddWith fdIf.Show=-1 Then'定义单个文件变量Dim vrtSelectedItem As Variant'定义循环量Dim i As Integeri=1'开始文件检索For Each vrtSelectedItem In.SelectedItems'打开被合并工作簿Dim tempwb As WorkbookSet tempwb=Workbooks.Open(vrtSelectedItem)'复制工作表tempwb.Worksheets(1).Copy Before:=newwb.Worksheets(i)'把新工作簿的工作表名字改成被复制工作簿文件名，这儿应用于xls文件，即Excel97-2003的文件，如果是Excel2007，需要改成xlsxnewwb.Worksheets(i).Name=VBA.Replace(,".xls","")'关闭被合并工作簿tempwb.Close SaveChanges:=Falsei=i+1Next vrtSelectedItemEnd IfEnd WithSet fd=NothingEnd Sub5、将含有多个sheet的工作表内容信息汇总至一个sheet中Sub Combine()Dim J As IntegerOn Error Resume NextSheets(1).SelectWorksheets.AddSheets(1).Name = "Combined"Sheets(2).ActivateRange("A1").EntireRow.SelectSelection.Copy Destination:=Sheets(1).Range("A1")For J = 2 To Sheets.CountSheets(J).ActivateRange("A1").SelectSelection.CurrentRegion.SelectSelection.Offset(1, 0).Resize(Selection.Rows.Count - 1).SelectSelection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)NextEnd Sub。
VBA程序设计（实例精讲）
VBA程序设计（实例精讲）第2章VBA程序设计2.1⼯作簿和⼯作表⼀、创建和打开⼯作簿Workbooks.Add创建⼀个新的⼯作簿SetNewBook=Workbooks.Add建⼯作簿，⽤对象变量表⽰NewBook.SaveAsFilename:="Test.xls"⼯作簿另存为Workbooks.Open("D:\Test.xls")打开⼯作簿⼆、引⽤⼯作表Worksheets(1).Activate激活第⼀张⼯作表Sheets(4).Activate激活四张⼯作表Worksheets("Sheet1").Activate激活指定的⼯作表Sheets("Chart1").Activate激活图表“Chart1”2.2单元格和区域⼀、引⽤单元格和区域1．⽤A1样式记号引⽤单元格和单元格区域表2.1使⽤Range属性的A1样式引⽤⽰例【例2.6】将⼯作表“Sheet1”中单元格区域A1:D5的字体设置为加粗。
Sheets("Sheet1").Range("A1:D5").Font.Bold=True2.⽤编号引⽤单元格【例2.7】将Sheet1上的单元格A6的Value属性设置为10Worksheets("Sheet1").Cells(6,1).Value=10【例2.9】清除活动⼯作簿中Sheet1上的所有单元格的内容Worksheets("Sheet1").Cells.ClearContents【例2.10】假设⼯作簿中Sheet1的A列是员⼯姓名（不超过50⼈），Sheet2的A列是员⼯姓名、B列是对应的电话号码。
现在需将所有员⼯的电话号码填写到Sheet1中的B列(注：Sheet1中姓名“李三”在Sheet2中可能为“李三”，中间没有空格)。
VBA模块的编程过程(ppt 21页)
中文版Access 2007实用教程
12.5 创建VBA模块
模块是将VBA代码的声明、语句和过程作为一个单元进行保存的集合，是 基本语言的一种数据库对象，数据库中的所有对象都可以在模块中进行引用。 利用模块可以创建自定义函数、子程序以及事件过程等，以便完成复杂的计算 功能。模块可以代替宏，并可以执行标准宏所不能执行的功能。
中文版Access 2007实用教程
12.6.1 设置密码保护Visual Basic代码
用户可以通过对VBA代码设置密码来防止其他非法用户查看或编辑数据 库中的程序代码。
中文版Access 2007实用教程
12.6.2 生成ACCDE文件
除了使用密码保护VBA代码以外，还可以通过创建ACCDE文件保护程序 代码。ACCDE文件是旧版本Access中的.mde 文件的Access 2007版本。
过程是包含VBA代码的基本单位，可以完成一系列指定的操作。过程由 计算的语句和方法组成，通常分为Sub过程、Function过程和Property过程。 其中，Sub过程是最常用的过程类型，也称为命令宏，可以传送参数和使用参 数来调用它，但不返回任何值；Function过程也称为自定义函数过程，其运行 方式和使用程序的内置函数一样，即通过调用Function过程获得函数的返回值； Property过程能够处理对象的属性。
中文版Access 2007实用教程
12.2.1 常量、变量和数组
在VBA中，程序是由过程组成的，过程又由根据VBA规则书写的指令组 成。一个程序包括常量、变量、运算符、语句、函数、数据库对象和事件等基 本要素。
常量 变量 数组
中文版Access 2007实用教程
12.2.2 数据类型
ExcelVBA项目开发案例精选
ExcelVBA项目开发案例精选前言Excel是一款大家极为熟悉、使用极为广泛的电子表格软件。
强大的数据统计，方便的图表制作等功能深受使用者赞誉。
其实Excel的功能远不仅仅如此，在Excel及Office其它软件中还集成了一个开发环境，利用VBA编程进行二次开发，扩充Excel功能，轻松完成复杂而重复的各项操作。
VBA是Excel使用者的福音，是名副其实的Excel的万能工具。
掌握VBA编程会使人们的工作更轻松，更方便。
由于VBA出生于Visual Basic，所以它具有入门容易，应用广泛的特点，还具有开发环境与运行环境无要求，数据库与程序集于一身等优点，经常被用于一些数据管理以及小型系统的开发。
本人是一名教师，在教学实践中开发了许多实用的教学软件。
现精选其中的九款软件编辑成册，奉献给读者。
这些软件既具有一定的实用价值，更重要的是使读者进一步了解VBA的编程方法、开发技巧以及许多算法的实现途径，迅速提高编程水平。
章节安排第1章VBA开发基本技能本章简单介绍了VBA开发人员必须掌握的十大基本技能。
主要有：了解开发环境、熟练宏操作、获取帮助信息、程序调试、熟练掌握基本语法、过程操作、访问Excel各类对象、用户窗体及控件设计、利用FSO 访问文件和文件夹、访问数据库等技术。
第2章中英文输入练习软件键盘输入是每个计算机操作人员的最基本技能。
本软件给用户提供了一个中英文输入的练习环境。
软件根据键盘分布和五笔汉字输入规则，对练习项目合理分类、集中练习、强化记忆、由浅入深、循序渐进组织练习。
软件涉及到的技术主要有：FSO文件系统对象、局域网工作簿的访问、窗体工具栏状态栏的操作、Windows造字程序的使用、图片列表、TreeView、ListView等控件的使用方法。
第3章汉字录入测试系统汉字录入测试在许多场合都有其实用价值。
汉字录入水平高低的测试主要在于速度和准确率的判定。
本软件可以检测录入时间并按照最小错误原则对所录入的文本进行校对，判断出错字、多字以及少字的数量。
100个vba例子程序
100个vba例子程序基本代码这些 VBA 代码将帮助您快速执行一些您经常在电子表格中执行的基本任务1.添加序列号此宏代码将帮助您在Excel 工作表中自动添加序列号，如果您处理大数据，这对您很有帮助。
要使用此代码，您需要选择要从其中开始序列号的单元格，当您运行此代码时，它会显示一个消息框，您需要在其中输入序列号的最高编号，然后单击确定。
一旦您单击“确定”，它就会简单地运行一个循环并将序列号列表添加到向下的单元格中。
2.插入多列此代码可帮助您单击一次输入多个列。
当您运行此代码时，它会询问您要添加的列数，当您单击确定时，它会在所选单元格之后添加输入的列数。
如果要在所选单元格之前添加列，请将代码中的xlToRight 替换为 xlToLeft。
3.插入多行使用此代码，您可以在工作表中输入多行。
运行此代码时，您可以输入要插入的行数，并确保选择要插入新行的单元格。
如果要在所选单元格之前添加行，请将代码中的 xlT oDown 替换为 xlT oUp。
4. 自动调整列此代码可快速自动适应工作表中的所有列。
因此，当您运行此代码时，它将选择工作表中的所有单元格并立即自动调整所有列。
5. 自动调整行您可以使用此代码自动调整工作表中的所有行。
当您运行此代码时，它将选择工作表中的所有单元格并立即自动适应所有行。
6.删除文本换行此代码将帮助您通过单击从整个工作表中删除文本换行。
它将首先选择所有列，然后删除文本换行并自动适应所有行和列。
您还可以使用 (Alt + H +W) 的快捷方式，但如果将此代码添加到快速访问工具栏，它比键盘快捷方式更方便。
7. 取消合并单元格此代码仅使用 HOME 选项卡上的取消合并选项。
使用此代码的好处是您可以将其添加到 QAT 并取消合并选择中的所有单元格。
如果您想取消合并特定范围，您可以通过替换单词选择在代码中定义该范围。
8. 打开计算器在Windows 中，有一个特定的计算器，通过使用此宏代码，您可以直接从 Excel 打开该计算器。
vba小程序实例
vba小程序实例VBA小程序实例VBA（Visual Basic for Applications）是一种用于宏编程的编程语言，常用于Microsoft Office软件中。
通过编写VBA小程序，我们可以实现自动化处理数据、操作软件等功能。
本文将通过几个实例来展示VBA小程序的具体应用。
一、实例一：批量处理Excel表格数据假设我们需要对一个包含大量数据的Excel表格进行处理，例如筛选、排序、求和等操作。
使用VBA小程序可以大大提高工作效率。
我们打开Excel软件，按下“Alt + F11”快捷键，打开VBA编辑器。
然后在工程资源管理器中选择“插入”-“模块”，在新建的模块中编写VBA代码。
代码示例：Sub Data_Processing()' 定义变量Dim ws As WorksheetDim rng As Range' 设置工作表和数据范围Set ws = ThisWorkbook.Worksheets("Sheet1")Set rng = ws.Range("A1:E10")' 进行数据处理rng.AutoFilter Field:=1, Criteria1:=">100" ' 筛选大于100的数据' 其他数据处理操作...End Sub上述代码中，我们首先定义了两个变量ws和rng，分别表示工作表和数据范围。
然后通过设置工作表和数据范围，我们可以对指定范围内的数据进行处理。
例如，上述代码中使用了“AutoFilter”方法对第一列数据进行筛选，只显示大于100的数据。
二、实例二：自动发送邮件在日常工作中，我们经常需要发送邮件给固定的收件人。
使用VBA 小程序，我们可以编写一个自动发送邮件的程序，实现批量发送邮件的功能。
我们同样需要打开VBA编辑器。
然后在工程资源管理器中选择“插入”-“模块”，在新建的模块中编写VBA代码。
VBA程序设计
VBA程序设计VBA (Visual Basic for Applications) 是一个基于微软的 Visual Basic 编程语言的应用程序编程接口（API），用于自动化和定制微软应用程序，如Excel、Word、PowerPoint等。
实例一：自动填充Excel单元格在Excel中，当我们需要填充一列或一行相同的内容时，可以使用VBA 来实现自动填充。
然后，在代码窗口中编写以下VBA代码：```vbaSub AutoFillCellsRange("A1").Value = "Hello"Range("A2").Value = "World"Range("A3:A10").Value = Range("A1:A2").ValueEnd Sub```在这个例子中，我们首先在 A1 单元格中写入 "Hello"，在 A2 单元格中写入 "World"。
然后，我们使用 Range 函数和 Value 属性来将 A1 和 A2 单元格的值自动填充到 A3 到 A10 单元格中。
实例二：自动创建PowerPoint幻灯片VBA 还可以用于自动创建 PowerPoint 幻灯片。
我们可以编写 VBA 代码来添加幻灯片、插入文本和图片等操作。
然后，在代码窗口中编写以下VBA代码：```vbaSub CreateSlideDim pptApp As PowerPoint.ApplicationDim pptPres As PowerPoint.PresentationDim pptSlide As PowerPoint.Slide' 创建 PowerPoint 对象Set pptApp = New PowerPoint.Application'打开一个新的演示文稿Set pptPres = pptApp.Presentations.Add'在演示文稿中插入一个新的幻灯片Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, PowerPoint.PpSlideLayout.ppLayoutBlank)'在幻灯片中插入文本框并输入文本WithpptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizo ntal, Left:=100, Top:=100, Width:=400, Height:=200).TextFrame.TextRange.Text = "Hello, World!"End With'保存演示文稿pptPres.SaveAs "C:\path\to\save\file"' 关闭 PowerPoint 对象pptPres.ClosepptApp.Quit'释放对象Set pptSlide = NothingSet pptPres = NothingSet pptApp = NothingEnd Sub```在这个例子中，我们首先创建了一个 PowerPoint 对象，然后打开一个新的演示文稿。
VBA编程实例
VBA编程实例第九章工作表排序本章只有一个范例文件，主要功能对活动工作簿中所有工作表进行排序。
算法说明:1、统计活动工作簿中工作表的数量WsCount=Activeworkbook.worksheets.count2、定义一个一维数组a(1 to wscount)主要用来存放活动工作簿中所有工作表名称字符串 3、利用for each ws in activeworkbook.worksheets 循环将活动工作簿中所有数量赋值给一维数组 4、利用冒泡法对数组进行排序(源文件对排序单独写了一个过程)5、利用worksheets的move方法以及sheets(i)(他代表工作簿中从左到右第i张工作表)移动工作表代码:Sub SortSheet()Dim WsCount As IntegerDim WsArray() As StringDim Ws As WorksheetOn Error Resume NextWsCount = ActiveWorkbook.Worksheets.Count ReDim WsArray(1 To WsCount) If ActiveWorkbook.ProtectStructure ThenMsgBox & " 被保护，不能进行排序，请解除保护后排序", _vbCritical, "不能排序工作表"Exit SubEnd IfFor Each Ws In ActiveWorkbook.Worksheetst = t + 1WsArray(t) = Next Ws'对数组进行排序For i = 1 To UBound(WsArray) - 1For j = i + 1 To UBound(WsArray)If WsArray(i) > WsArray(j) Thent = WsArray(i)WsArray(i) = WsArray(j)WsArray(j) = tEnd IfNext jNext i'利用Move方法以及Sheets(i)移动工作表，按指定的顺序排列For i = 1 To WsCountWorksheets(WsArray(i)).Move before:=Sheets(i) Next iEnd Sub第七章批注1、Comment为Range对象的属性2、Comments返回指定工作表中所有的批注，可以利用For each对工作表中所有批注循环题目:(1)根据批注的作者，删除批注(2)隐藏工作表中所有批注(3)为区域中添加批注(4)测试Comments(index)返回指定工作表中第index个批注Sub 统计批注个数()Dim Flag As Comment'1、Comments返回指定工作表中所有的批注'2、用Comment属性返回一个Comment对象For Each Flag In mentst = t + 1Next FlagMsgBox "活动工作表中共有:" & t & "个批注", vbOKOnly, "统计批注个数" End SubSub CountComment()Dim Flag As Range'利用err来判断是否发生错误For Each Flag In edRangeOn Error Resume Nextt = ment.TextIf Err = 0 Then k = k + 1 Next FlagMsgBox "活动工作表中共有:" & k & "个批注", vbOKOnly, "统计批注个数" End SubSub 选定批注单元格()Dim a() As RangeDim Flag As RangeReDim a(ments.Count) For i = 1 To ments.CountSet a(i - 1) = ments(i).ParentNext iSet Flag = aFlag.SelectEnd SubSub selectcomment()'使用编辑定位功能，定位批注，选定单元格Cells.SpecialCells(xlCellTypeComments).SelectEnd SubSub 显示或隐藏批注()Dim Flag As CommentFor Each Flag In mentsIf Flag.Visible = True ThenFlag.Visible = FalseElseFlag.Visible = TrueEnd IfNext FlagEnd SubSub DisHideComment()'利用application的displaycommentindicator属性来显示隐藏批注'Indicator表示批注的标识符If Application.DisplayCommentIndicator = xlCommentAndIndicator Then Application.DisplayCommentIndicator = xlCommentIndicatorOnlyElseApplication.DisplayCommentIndicator = xlCommentAndIndicatorEnd IfEnd SubSub 输出所有批注()'在Sheet2工作表中返回Sheet1工作表中所有批注'这里使用ment.text返回批注中的内容Dim Flag As CommentDim t As Integeri = 1With Worksheets("Sheet2").Cells.Clear.Cells(1, 1) = "第n个批注".Cells(1, 2) = "批注地址".Cells(1, 3) = "批注内容"For Each Flag In Worksheets("Sheet1").Commentsi = i + 1t = t + 1.Cells(i, 1) = t.Cells(i, 2) = Flag.Parent.Address.Cells(i, 3) = ment.TextNext Flag.Columns("B:B").EntireColumn.AutoFit.Columns("C:C").ColumnWidth = 34.Cells.EntireRow.AutoFitEnd WithEnd SubSub 改变批注颜色()Dim Flag As CommentFor Each Flag In mentsFlag.Shape.Fill.ForeColor.SchemeColor = Int((80) * Rnd + 1) '1-80 Flag.Shape.TextFrame.Characters.Font.ColorIndex = Int((56) * Rnd + 1) '1-56Next FlagEnd SubSub 添加批注()Dim Flag As RangeOn Error Resume NextFor Each Flag In ActiveSheet.Range("g8:i17")t = t + 1Flag.AddComment.Text "hner:这是我添加的第" & t & "个批注" & Chr(13)+ Chr(10) & DateNext FlagEnd SubSub test()MsgBox ActiveSheet.Range("g8").Comment.AuthorEnd SubSub 删除批注()Dim Flag As RangeFor Each Flag In ActiveSheet.Range("g8:i17")ment.DeleteNext FlagEnd Sub第十章自定义函数函数一:计算销售佣金题1:根据销售额和对应的佣金率计算 =Sales*Rate 题2:根据销售额和对应的佣金率以及工作年限计算，工作每满一年佣金在原来的基础上增加一个百分点=Sales*Rate*(1+Year/100)条件临界点佣金率[0，10000) 0 0.08[10000，20000) 10000 0.105[20000，40000) 20000 0.12[40000，无穷) 40000 0.14计算方法:1、利用vlookup函数的模糊查找:=VLOOKUP(B2,$B$14:$C$17,2,TRUE)*B2 定期维护佣金率2、利用if函数结合&连接符突破if七层嵌套问题:=IF(AND(B2>=0,B2<$B$15),B2*$C$14,"")&IF(AND(B2>=$B$15,B2<$B$16),B2*$C$15,"")&IF(AND(B2>=$B$16,B2<$B$17), B2*$C$16,"")&IF(AND(B2>=$B$17),B2*$C$17,"")3、利用自定义函数，代码如下:Function Commission1(Sales, years) '计算销售佣金，工作每满一年，销售佣金在原来的基础上增加一个百分点 Const Rate1 = 0.08Const Rate2 = 0.105Const Rate3 = 0.12Const Rate4 = 0.14Select Case SalesCase 0 To 9999.99 'Case a to b 表示[a,b]两边都是闭区间Commission1 = Sales * Rate1Case 10000 To 19999.99Commission1 = Sales * Rate2Case 20000 To 39999.99Commission1 = Sales * Rate3Case ElseCommission1 = Sales * Rate4 End Select'每工作满一年，佣金在原来的基础上增加1个百分点Commission1 = Commission1 * (1 + years / 100)End FunctionSub 计算销售佣金()’在工作表中设计一个窗体按钮，执行此代码Dim SalesDim years As IntegerSales = Val(InputBox("请输入销售额:", "计算销售佣金"))years = Val(InputBox("请输入工作年限:", "计算销售佣金"))y = MsgBox("您的佣金为:" & Commission1(Sales, years), vbYesNo, "计算销售佣金") If y = vbYes Then '这里使用msgbox信息框，当单击是的时候，调用该过程本身计算销售佣金 End IfEnd Sub函数二:随机抽取某区域中的一个单元格目的:理解Optional定义变量和非易失性函数Volatile1、易失性函数:顾名思义该函数很容易改变，也就是无论何时在工作表任意单元格输入数据，易失性函数都需要重新计算，结合本例，只要在任意单元格输入数据，易失性函数都重新计算2、非易失性函数:顾名思义该函数不容易改变，也就是只有在函数中的参数值发生变化时，非易失性函数才重新计算，否则不计算，结合本例，只有在a1:a10输入数据，非易失性函数才重新计算，否则不计算3、Optional申明变量，表示该变量为可选参数4、假如Region为一个range对象区域，那么Region(i)表示区域Region中第i个对象代码如下:Function UnderstandVolatile(Region As Range, Optional FlagBoolean As Boolean = False)'利用optional定义变量表示该变量为可选参数'理解非易失性函数'函数功能:随机抽取Region区域中的一个单元格值'当application.volatile true时，表示易失性函数Application.Volatile FlagBoolean'产生[a,b]之间的随机整数 Int(rnd()*(b-a+1)+1)UnderstandVolatile = Region(Int(Rnd() * (Region.Count) + 1))End Function函数三:利用Optional来确定自定义函数是一个多单元格数组函数还是一个普通函数 MonthNames(OptionalMindex)函数功能:返回月份可选参数:1、当无参数时，返回一个多单元格数组公式，横向数组，将一个数组直接赋值给自定义函数2、当参数大于等于1时，返回对应月份，如参数为1，则返回Jan，参数为13，也同样返回Jan3、当参数小于等于0时，返回一个多单元格数组公式，垂直数组代码如下:Function MonthNames(Optional Mindex) '返回月份'Ismissing(t)表示t是否传递给过程，如果没有传递，则返回trueDim AllNames As VariantAllNames = Array("Jan", "Feb", "Mar", _"Apr", "May", "Jun", "Jul", "Aug", _"Sep", "Oct", "Nov", "Dec")If IsMissing(Mindex) ThenMonthNames = AllNamesElseSelect Case MindexCase Is >= 1'如果参数为1，则返回Jan，为数组的第一个元素，故应该用(Mindex-1 mod 12)，数组的下限为0，即AllNames(0)MonthNames = AllNames((Mindex - 1) Mod 12)Case ElseMonthNames = Application.WorksheetFunction.Transpose(AllNames)End SelectEnd IfEnd Function这里使用一个ismissing函数，该函数主要是用来测试是否将参数传递给过程，如果没有传递，则返回TRUE。
- 1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。
VBA程序教学用例【例1】求解一元二次方程Ax2+Bx+C=0。
顺序结构的VBA程序：SUB JFC1()A = Sheets("解一元二次方程").Cells(1, 2)B = Sheets("解一元二次方程").Cells(2, 2)C = Sheets("解一元二次方程").Cells(3, 2)X1=(-B+SQR(B^2-4*A*C))/2/AX2=(-B-SQR(B^2-4*A*C))/2/ADEBUG.PRINT “X1=”,X1DEBUG.PRINT “X2=”,X2END SUB提示：先将三个系数A、B、C存放到表"解一元二次方程"的单元格B1:B3中，运行结果在立即窗口中（可用CTRL+G组合键打开立即窗口）。
带判断条件的VBA程序：Sub JFC2()A = Sheets("解一元二次方程").Cells(1, 2)B = Sheets("解一元二次方程").Cells(2, 2)C = Sheets("解一元二次方程").Cells(3, 2)If B * B - 4 * A * C >= 0 ThenSheets("解一元二次方程").Cells(4, 2) = (-B + Sqr(B ^ 2 - 4 * A * C)) / 2 / A Sheets("解一元二次方程").Cells(5, 2) = (-B - Sqr(B ^ 2 - 4 * A * C)) / 2 / A ElseSheets("解一元二次方程").Cells(4, 2) = "此方程无实根"Sheets("解一元二次方程").Cells(5, 2) = "此方程无实根"End IfEnd Sub提示：先将三个系数A、B、C存放到表"解一元二次方程"的单元格B1:B3中，运行结果在B4:B5中）。
【例2】给定成绩数据在表sheet2中，求最高分、最低分和平均分。
（1）程序流程总图求N个数平均值的算法流程“打擂法”求最大的算法流程（2）VBA程序Sub CJTJ()X = Sheets("成绩统计").Cells(2, 2)MA = XMI = XP = 0I = 2Do While Sheets("成绩统计").Cells(I, 2) <> ""X = Sheets("成绩统计").Cells(I, 2)P = P + XIf X > MA Then MA = XIf X < MI Then MI = XI = I + 1LoopP = P / (I - 2)Sheets("成绩统计").Cells(I + 1, 1) = "最高分"Sheets("成绩统计").Cells(I + 1, 2) = MASheets("成绩统计").Cells(I + 2, 1) = "最低分"Sheets("成绩统计").Cells(I + 2, 2) = MISheets("成绩统计").Cells(I + 3, 1) = "平均分"Sheets("成绩统计").Cells(I + 3, 2) = PEnd Sub思考题：如果要在CJTJ程序中增加计算标准差功能，程序该如何修改？【例3】打印九九乘法表。
Sub 九九乘法表()Dim i as integer, j as integerFor i=1 to 9For j=1 to 9Sheets(“九九乘法表”).Cells(I,j)= I & ”*” & j & ”=” & i*jNext jNext iEnd sub程序说明：（1）循环嵌套：外循环I循环，内循环J循环；（2）关键语句：Sheets(“九九乘法表”).Cells(I,j)= I & ”*” & j & ”=” & i*j思考题：如何打印主对角线下面的三角形状的九九乘法表？【例4】打印N以内的素数。
（1）流程图(2) 程序代码Public Sub 打印N以内的素数()Dim I As Integer, J As Integer, K As Integer, R As Integer, N As Integer, H As IntegerN = Sheets("SHEET1").Cells(1, 2)R = 3H = 1For I = 2 To NK = 0For J = 1 To IIf I Mod J = 0 ThenK = K + 1End IfNext JIf K = 2 ThenIf H > 15 ThenH = 1R = R + 1End IfSheets("SHEET1").Cells(R, H) = IH = H + 1End IfNext IEnd Sub【例5】问卷统计。
（1）流程图(2) 程序代码Public Sub 问卷统计()Dim I As Integer, N As Integer, J As Integer, X As String, L As Integer, X1 As String, S(9, 4) As IntegerWorksheets("问卷统计1").ActivateI = 2Do While Sheets("问卷统计1").Cells(I, 1) <> ""I = I + 1LoopN = I - 2L = Len(Sheets("问卷统计1").Cells(N, 1))For I = 1 To NX = Sheets("问卷统计1").Cells(I + 1, 1)For J = 1 To LX1 = Mid$(X, J, 1)K = Asc(X1) - 64S(J, K) = S(J, K) + 1Next JNext IFor I = 1 To 4Sheets("问卷统计1").Cells(1, I + 2) = Chr$(I + 64) Next IFor I = 1 To LSheets("问卷统计1").Cells(I + 1, 2) = IFor J = 1 To 4Sheets("问卷统计1").Cells(I + 1, J + 2) = S(I, J)Next JNext IEnd Sub【例6】随机点将。
Private Sub CommandButton1_Click() Dim i As Integer Dim n As IntegerDim xh As IntegerDim xm As String Dim x As LongWorksheets(ComboBox1.Value).Activate *选中表 i = 2Do While Sheets(ComboBox1.Value).Cells(i, 1) <> ""i = i + 1Loop n = i - 2 Randomizexh = Int(n * Rnd) + 1 *随机产生一个序号xm = Sheets(ComboBox1.Value).Cells(xh + 1, 2).Value *取相应姓名 If Sheets(ComboBox1.Value).Cells(xh + 1, 10).Value <> 1 Then TextBox1.Value = xhTextBox2.Value = xmSheets(ComboBox1.Value).Cells(xh + 1, 10).Value = 1End If *如果本次点将已点过则不显示抽到者信息，重新抽取 End Sub【进入VBA 程序】*定义变量*获取总人数*如果本次点将尚未点过则显示抽到者信息【例7】 计算定积分 baxdx sin 。
(0≦a<b ≦π)方法一：梯形法 SUB DJF()A=SHEETS(“定积分计算”).CELLS(3,2) B=SHEETS(“定积分计算”).CELLS(4,2) N=SHEETS(“定积分计算”).CELLS(5,2) S=0FOR I= 1 TO NS=S+(SIN((I-1)/N)+SIN(I/N))/2/N NEXT ISHEETS(“定积分计算”).CELLS(6,2)=S END SUB方法二：蒙特卡洛法Public Sub 蒙托卡洛法计算定积分()Dim N As Single, J As Single, M As Single, A As Single, B As Single N = Sheets("定积分计算").Cells(13, 2) A = Sheets("定积分计算").Cells(11, 2) B = Sheets("定积分计算").Cells(12, 2) M = 0 J = 1Do While J <= N Randomize X = B * Rnd Y = RndIf Y <= Sin(X) Then M = M + 1 J = J + 1 LoopSheets("定积分计算").Cells(14, 2) = M / N * B End Sub【例8】儿童算术练习与测试。
功能要求1. 随机抽题：随机抽取100以内范围的整数加减法题，减法时保证减数不大于被减数；2. 评判正误：当练习者（或被测试）提交答案时，给出评判结果，并自动计算正确率。
抽题VBA程序：Public COUNTN As Integer, COUNTN1 As IntegerSub 抽题()Sheets("儿童算术训练").Cells(8, 2) = "?"RandomizeX = Int(Rnd() * 100)Y = Int(Rnd() * 100)Z = "-"If Rnd() < 0.5 Then Z = "+"If Z = "-" And X < Y ThenT = XX = YY = TEnd IfSheets("儿童算术训练").Cells(8, 3) = XSheets("儿童算术训练").Cells(8, 5) = ZSheets("儿童算术训练").Cells(8, 6) = YSheets("儿童算术训练").Cells(8, 8) = "="Sheets("儿童算术训练").Cells(8, 9) = ""Sheets("儿童算术训练").Cells(17, 3) = "输入答案并按Enter键"Range("I8").SelectEnd Sub评判正误VBA程序：Sub 提交答案()COUNT1 = COUNT1 + 1X = Sheets("儿童算术训练").Cells(8, 3)Z = Sheets("儿童算术训练").Cells(8, 5)Y = Sheets("儿童算术训练").Cells(8, 6)If Evaluate(X & Z & Y) = Sheets("儿童算术训练").Cells(8, 9) Then Sheets("儿童算术训练").Cells(8, 2) = "√"COUNT2 = COUNT2 + 1Sheets("儿童算术训练").Cells(17, 3) = "棒极了，继续努力！" ElseSheets("儿童算术训练").Cells(8, 2) = "×"Sheets("儿童算术训练").Cells(17, 3) = "你真笨，要努力哦！" End IfSheets("儿童算术训练").Cells(12, 10) = COUNT2 / COUNT1End Sub。