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。
Excel VBA编程常用实例 例
图 00-06：刚打开 VBE 编辑器时的窗口 可以在“工程资源管理器”中双击任一对象打开代码窗口，或者选择菜单“插入—— 模块”或“插入——类模块”来打开代码窗口。一般 VBE 编辑器窗口及各组成部件 名称如图 00-07 所示，可以通过“视图”菜单中的菜单项选择所出现的窗口。同时， 可以在“工程属性”窗口中设置或修改相应对象的属性。
图 00-09：帮助搜索窗口
■ 可以按 F2 键，调出“对象浏览器”窗口(如图 00-10 所示)，在搜索文本框中输 入需要帮助的关键词，将会在“搜索结果”中出现一系列相关的对象及方法、属性
7
列表，单击相应的对象则会在“类”和“成员”列表框中显示相应的对象和方法、属 性成员列表，在成员列表中相应的项目上按 F1 键即会出现详细的帮助信息。(“对 象浏览器”是一个很好的帮助工具，值得好好研究)
示例 01-03：处理光标(Cursor 属性) Sub ViewCursors()
图 00-10：对象浏览器窗口 参考资料 《ExcelVBA 编程入门范例》参考或引用了以下书籍和资料： (1)Excel 2003 高级 VBA 编程宝典
8
(2)Excel 2003 与 VBA 编程从入门到精通(中文版) (3)巧学巧用 Excel 2003 VBA 与宏(中文版) (4)ExcelVBA 应用程序专业设计实用指南 (5)ExcelVBA 应用开发与实例精讲 (6)一些网上资源
1
图 00-01：选择菜单“工具——宏——Visual Basic 编辑器”命令来打开 VBE 编辑 器
图 00-02：选择 Visual Basic 工具栏上的“Visual Basic 编辑器”命令按钮来打开 VBE 编辑器 此外，您也可以使用下面三种方式打开 VBE 编辑器：
第8章 VBA程序设计
在程序代码中通过赋值语句设置对象属性的格式: 对象名.属性名=表达式
(2)方法
对象的方法是系统预先设定的、对象能执行的操 作，实际上是将一些已经编好的通用的函数或过程封 装起来，供用户直接调用。因为方法是面向对象的， 不同的对象有不同的方法，所以在调用时一定要指明 哪个对象调用哪个方法。对象方法调用的格式为:
对象名.方法名 参数表
(3)对象事件
对象事件是指在对象上发生的、系统预先定义的能被对 象识别的一系列动作。
正数：1.401298E-45~3.402823E38
双精度型 Double #
8(64位)
负数：-1.79769313486232D308~
-4.94065645841247D-324
正数：4.94065645841247D-324~
1.79769313486232D308
货币型 Currency @ 8(64位)
Single和Double型数据用于存储浮点数(带小数部分的实 数，小数点可位于数字的任何位置)。
单精度最多表示7位有效数字，双精度最多表示15位有效 数字。如果超出表示范围，可以用科学记数法表示，即表 示成10的幂次方形式，如3.218E6，7.3487D-6等。
Single(单精度型)数据有多种表示形式，类型符为！ Double(双精度型)数据也有多种表示形式，类型符为#，
事件分为系统事件和用户事件。 系统事件是由系统自动产生的事件，如窗体的Load(加 载)等； 用户事件是由用户操作引发的事件，如鼠标的单击 (Click)、值的改变(Change)、键盘按下(Key Press)等事件。
VBA代码操作代码
VBA代码操作代码'VBE对象是根对象，表示在VBA编辑器中存在的所有对象的最上层对象'一 VBAproject对象: VBE编辑器中的工程'1 VBComponents对象：表示工程中所有的部件集合，包括Excel对象、窗体、模块、类模块。
'1) CodeModule 对象：表示部件中相关的代码'操作VBE需要做的工作'1 设置信任'excel2003中，工具--宏--安全性--可靠发行商，选中“信任对于...''excel2007和excel2010，开发工具--安全性--宏设置--选中'对...的信任''2 引用Option Explicit'1、返回模块的行数Sub 返回模块A中的总行数()MsgBoxThisWorkbook.VBProject.VBComponents('A').CodeModule.Coun tOfLinesEnd SubSub 返回过程test中的总行数()MsgBoxThisWorkbook.VBProject.VBComponents('A').CodeModule.Proc CountLines('test', vbext_pk_Proc)End SubSub 返回过程fe中开始行数()MsgBoxThisWorkbook.VBProject.VBComponents('A').CodeModule.Proc BodyLine('fe', vbext_pk_Proc)End Sub'vbext_pk_Get 指定一个返回属性值的过程'vbext_pk_Let 指定一个赋值给属性的过程'vbext_pk_Set 指定一个给对象设置引用的过程'vbext_pk_Proc 指定所有过程除了Property 过程'2 返回模块的内容Sub 返回过程fe中的所有代码()Dim 开始行数, 总行数WithThisWorkbook.VBProject.VBComponents('A').CodeModule 开始行数 = .ProcBodyLine('fe', vbext_pk_Proc)总行数 = .ProcCountLines('fe', vbext_pk_Proc)MsgBox .Lines(开始行数, 总行数)End WithEnd SubSub 返回第7行所在的过程名()MsgBoxThisWorkbook.VBProject.VBComponents('A').CodeModule.Proc OfLine(7, vbext_pk_Proc)End Sub'判断模块和过程是否存在Sub 判断A模块是否存在()On Error Resume NextIf ThisWorkbook.VBProject.VBComponents('c') Is Nothing ThenMsgBox 'B模块没有存在'ElseMsgBox 'B模块存在'End IfEnd SubSub 判断是否存在b过程()'On Error Resume NextDim 开始行数开始行数= ThisWorkbook.VBProject.VBComponents('A').CodeModule.Proc BodyLine('B', vbext_pk_Proc)If Err.Number = 35 ThenMsgBox '不存在B过程'ElseMsgBox '存在B过程'End IfEnd Sub'返回工程中所有部件名称Sub 显示部件列表()Dim x As ByteWith ThisWorkbook.VBProjectFor x = 1 To .VBComponents.CountCells(x + 1, 1) = .VBComponents(x).NameCells(x + 1, 2) = .VBComponents(x).TypeNext xEnd WithEnd SubOption Explicit'一添加模块、过程、代码'1 添加模块Sub 添加新模块B()WithThisWorkbook.VBProject.VBComponents.Add(vbext_ct_StdMod ule).Name = 'B'End WithEnd Sub' vbext_ct_ClassModule 将一个类模块添加到集合' vbext_ct_MSForm 将窗体添加到集合' vbext_ct_StdModule 将标准模块添加到集合'2 在模块中添加代码Sub 添加新过程()Dim sr, codesr = 'Sub ABC()' & vbCrLf & 'Msgbox ''测试添加代码''' & vbCrLf & 'End Sub''MsgBox srWithThisWorkbook.VBProject.VBComponents('B').CodeModule .AddFromString srEnd With'3 在模块中插入代码Sub 在B模块中的第3行插入一行代码()WithThisWorkbook.VBProject.VBComponents('B').CodeModule .InsertLines 3, 'sheets(1).Select'End WithEnd Sub'二删除模块、过程、代码'1 删除模块Sub 删除B模块()With ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents('B') End WithEnd Sub'2 删除过程Sub 删除B模块中的ABC过程()Dim 开始行数, 总行数WithThisWorkbook.VBProject.VBComponents('B').CodeModule 开始行数 = .ProcBodyLine('ABC', vbext_pk_Proc)总行数 = .ProcCountLines('ABC', vbext_pk_Proc).DeleteLines 开始行数, 总行数End WithEnd Sub'三导入、导出和替换一个模块或代码Sub 导出一个模块()ThisWorkbook.VBProject.VBComponents('A').Export 'D:/A.bas'Sub 导入一个模块()ThisWorkbook.VBProject.VBComponents.Import 'D:/A.bas' End SubSub 替换一个模块()'先删除模块,然后导入新模块ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents('A')ThisWorkbook.VBProject.VBComponents.Import 'D:/A.bas' End SubSub 替换A模块的B程序第一行代码()Dim 开始行数WithThisWorkbook.VBProject.VBComponents('B').CodeModule 开始行数 = .ProcBodyLine('ABC', vbext_pk_Proc).ReplaceLine 开始行数 + 1, 'MsgBox ''修改后'''End WithEnd Sub'四模块的查找'Find(查找内容,开始行数,开始列始,结束行数,结束列数,是否匹配) Sub 在B模块中查找()WithThisWorkbook.VBProject.VBComponents('B').CodeModule MsgBox .Find('我', 1, 1, 1, 1)End WithEnd SubSub 引用列表()Dim ref, iFor Each ref In ThisWorkbook.VBProject.Referencesi = i + 1Cells(i, 1) = Cells(i, 2) = ref.FullPathCells(i, 3) = ref.DescriptionNext refEnd SubSub 引用IDE()ThisWorkbook.VBProject.References.AddFromFile'D:\Program Files\VB98\VB6EXT.OLB'End SubSub 添加字典引用()ThisWorkbook.VBProject.References.AddFromFile'C:\Windows\System32\scrrun.dll'End SubSub 给文件添加模块()Dim wb As Workbook, ph As StringApplication.DisplayAlerts = Falseph = ThisWorkbook.Path & '\'Set wb = Workbooks.Open(ph & 'test.xls')ThisWorkbook.VBProject.VBComponents('A').Export ph & 'A.bas'Windows().Visible = Truewb.VBProject.VBComponents.Import ph & 'A.bas'wb.Close TrueSet wb = NothingKill ph & 'A.bas'Application.DisplayAlerts = TrueEnd SubSub 删除指定文件模块()Dim wb As Workbook, ph As StringApplication.DisplayAlerts = Falseph = ThisWorkbook.Path & '\'Set wb = Workbooks.Open(ph & 'test.xls') Windows().Visible = Truewb.VBProject.VBComponents.Remove wb.VBProject.VBComponents('A')wb.Close TrueSet wb = NothingApplication.DisplayAlerts = TrueEnd Sub。
Excel VBA编程实例
Excel VBA编程实例Excel VBA（Visual Basic for Applications）是一种用于自动化Excel应用程序的编程语言。
通过编写VBA代码，我们可以在Excel中创建宏、自定义功能和自动化任务。
本文将介绍一些Excel VBA编程实例，以帮助读者更好地理解并应用VBA编程技巧。
1. 自动筛选数据在Excel中，我们经常需要根据特定条件筛选数据。
通过VBA编程，我们可以实现自动筛选数据的功能。
首先，我们需要打开Excel并进入VBA编辑器。
然后，编写以下代码：```vbaSub AutoFilterData()Dim ws As WorksheetSet ws = ThisWorkbook.Sheets("Sheet1") '将"Sheet1"替换为你的工作表名称With ws.Range("A1:D1").AutoFilter '将"A1:D1"替换为你要筛选的范围.Range("A1:D1").AutoFilter Field:=1, Criteria1:="Apple" '将1替换为你要筛选的列号，"Apple"替换为你要筛选的条件End WithEnd Sub```运行以上代码后，Excel将自动筛选出满足条件为“Apple”的数据。
2. 创建自动化报告Excel中的报告制作通常是非常繁琐的，但通过VBA编程，我们可以自动化这个过程。
以下代码演示了如何创建一个简单的销售报告：```vbaSub CreateReport()Dim ws As WorksheetDim reportWs As WorksheetDim lastRow As LongSet ws = ThisWorkbook.Sheets("Data") '将"Data"替换为包含数据的工作表名称Set reportWs = ThisWorkbook.Sheets.Add '添加一个新的工作表作为报告'设置报告表头reportWs.Range("A1") = "日期"reportWs.Range("B1") = "销售额"'计算数据行数lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row'填充数据reportWs.Range("A2:A" & lastRow).Value = ws.Range("A2:A" & lastRow).ValuereportWs.Range("B2:B" & lastRow).Formula = "=C2*D2" '假设C列为单价，D列为数量'添加图表Dim chartObj As ChartObjectSet chartObj = reportWs.ChartObjects.Add(110, 20, 300, 200)With chartObj.Chart.SetSourceData Source:=reportWs.Range("A1:B" & lastRow).ChartType = xlColumnClusteredEnd WithEnd Sub```运行以上代码后，Excel将创建一个新工作表作为报告，并将销售数据以及相应的图表添加到报告中。
一个完整的VBA画图程序
一个完整的VBA画图程序Sub 五月九月价差图()Dim ch As ChartObjectDim myrow As LongDim sh, sh59 As WorksheetDim rngD, rngc1, rngc2, rngp1, rngp2, rngs As RangeSet sh = Worksheets("workingarea")Set sh59 = Worksheets("九月减五月")sh59.Activatemyrow = sh.[a65536].End(xlUp).Row'-----------------------------------------------------------------------------------------------------------------------''定义时1为近月，2为远月，这样也为了以后方便修改Set rngD = sh.Range("a3:a" & myrow) '日期列Set rngc1 = sh.Range("e3:e" & myrow) '五月收盘Set rngc2 = sh.Range("h3:h" & myrow) '九月收盘Set rngp1 = sh.Range("g3:g" & myrow) '五月持仓Set rngp2 = sh.Range("j3:j" & myrow) '九月持仓Set rngs = sh.Range("o3:o" & myrow) '五九价差'开始绘图On Error GoTo err:sh59.ChartObjects("五九价差与持仓").Delete '确保这是唯一的图err:Set ch = sh59.ChartObjects.Add(0, 0, 600, 300) '定义位置极其大小 = "五九价差与持仓" '图表定名'为图表填加数据With ch.Chart.ChartType = xlLine.SeriesCollection.NewSeries '这个必须得有.SeriesCollection(1).Values = rngs '价差.SeriesCollection(1).XValues = rngD '横轴为时间.SeriesCollection(1).Name = "五九价差".SeriesCollection.NewSeries.SeriesCollection(2).Values = rngp1 '五月持仓.SeriesCollection(2).XValues = rngD.SeriesCollection(2).Name = "五月持仓".SeriesCollection.NewSeries.SeriesCollection(3).Values = rngp2 '九月持仓.SeriesCollection(3).XValues = rngD.SeriesCollection(3).Name = "九月持仓"End With'设置折线格式ch.Chart.SeriesCollection(1).AxisGroup = 2 '很奇怪，不能将这几句放到上一段去，可能是因为newseries的关系吧ch.Chart.SeriesCollection(1).MarkerStyle = xlNonech.Chart.SeriesCollection(2).AxisGroup = 1ch.Chart.SeriesCollection(2).MarkerStyle = xlNonech.Chart.SeriesCollection(3).AxisGroup = 1ch.Chart.SeriesCollection(3).MarkerStyle = xlNone'定义坐标主轴、副轴、横轴的格式With ch.Chart.Axes(xlValue, xlPrimary) '定义主y轴.MajorUnit = Int((WorksheetFunction.Max(rngp1.Value, rngp2.Value) * 1.5 - WorksheetFunction.Min(rngp1.Value, rngp2.Value)) / 100) * 100 / 10 '一开始我直接把最大值乘以1.2，最小值乘以0.8，可是遇到负数就麻烦了.MaximumScale = Int((WorksheetFunction.Max(rngp1.Value, rngp2.Value) * 1.5 + .MajorUnit) / 100) * 100.MinimumScale = Int((WorksheetFunction.Min(rngp1.Value, rngp2.Value) * -.MajorUnit) / 100) * 100.CrossesAt = .MinimumScale '与y轴交叉于最小值.TickLabels.Font.Size = 8 'y轴字体大小End WithWith ch.Chart.Axes(xlValue, xlSecondary) '定义副y轴.MajorUnit = (WorksheetFunction.Max(rngs.Value) - WorksheetFunction.Min(rngs.Value)) / 10.MaximumScale = Int((WorksheetFunction.Max(rngs.Value) + .MajorUnit) / 100) * 100.MinimumScale = Int((WorksheetFunction.Min(rngs.Value) - .MajorUnit) / 100) * 100.CrossesAt = .MinimumScale.TickLabels.Font.Size = 8End WithWith ch.Chart.Axes(xlCategory).TickLabels '定义x轴即分类轴的字体和格式.Font.Size = 8.NumberFormatLocal = "yy-m-d"End With'设置标题、图例格式和绘图区大小With ch.Chart.HasTitle = True.ChartTitle.Text = .ChartTitle.Font.Size = 12.ChartTitle.Font.Bold = True.ChartTitle.Left = ch.Width / 2.2.Legend.Font.Size = 8.PlotArea.Width = 580.PlotArea.Left = 10.PlotArea.Top = 10.PlotArea.Height = 290.ChartTitle.Top = .PlotArea.InsideTop .Legend.Left = .PlotArea.InsideLeft .Legend.T op = .PlotArea.InsideT op End WithSet ch = Nothingend sub。
VBA程序设计用例：程序流程图及程序代码
VBA程序设计⽤例：程序流程图及程序代码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中）。
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。
- 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。