excel常用的宏代码.doc

1、本示例为设置密码窗口 (1) If Application.InputBox(“请输入密码： “) = 1234 Then A1 = 1 密码正确时执行 Else: MsgBox “密码错误，即将退出！“ 此行与第 2 行共同设置密码 End If 本示例为设置密码窗口 (1) X = MsgBox(“是否真的要结帐？ “, vbYesNo) If X = vbYes Then Close 本示例为设置工作表密码 ActiveSheet.Protect Password:=641112 保护工作表并设置密码 ActiveSheet.Unprotect Password:=641112 撤消工作

2、表保护并取消密码 本示例关闭除正在运行本示例的工作簿以外的其他所有工作簿，并保存其更改内容。 For Each w In Workbooks If w.Name “Sheet1“ Then Row_dnN = .Range(“A65536“).End(xlUp).Row For i = 2 To Row_dn1 For j = 2 To Row_dnN If .Cells(j, 1) = Sheet1.Cells(i, 1) Then .Rows(j & “:“ & j).Copy Destination:=Sheet1.Rows(Row_dn1 + n & “:“ & Row_dn1 + n

3、) n = n + 1 End If Next j Next i End If End With Next wSheet End Sub 如果要用 VBA 程式输入密码使用下列程式码 Sub EnterNewPW() 程式说明: 利用 SendKey 输入 VBAProject 密码 注意事项: 执行本程式需要在 Excel 视窗,不能在 VBE 视窗 Application.SendKeys “%F11“, True Alt + F11 切换到 VBA 视窗 Application.SendKeys “%T“, True ALT + T 工具( 繁体中文是(T) Application.Se

4、ndKeys “e“, True 工具(T)-VBproject 属性(E) Application.SendKeys “TAB“, True TAB 键(切换到 PAge2 保护页面) Application.SendKeys “+“, True 选取 Checkbox 方块(锁定专案以供检视 ) (+ 选取, - 取消选取) Application.SendKeys “TAB“, True TAB 键(跳到第一次输入密码 Textbox myPW = “chijanzen“ 假设密码 chijanzen Application.SendKeys myPW, True 输入密码 Applic

5、ation.SendKeys “TAB“, True TAB 键(跳到第二次输入密码 Textbox Application.SendKeys myPW, True 输入密码 Application.SendKeys “ENTER“, True 按确定钮(预设值) Application.SendKeys “%F11“, True 返回 Excel 视窗 End Sub 冒泡排序法： 冒泡排序法之所以成为“冒泡排序”是因为值较小的或是较轻的元素浮到作为继续排序的一组数的顶部。 Sub Macro1() Dim i As Integer Dim j As Integer Dim t as int

6、eger Static number(1 To 10) As Integer For i = 1 To 10 number(i) = inputbox“输入要排序的数：” Next i For i = 10To 2 Step -1 For j = 1 To i 1 下面进行位置交换 If number(j) number(j + 1) Then t = number(j + 1) number(j + 1) = number(j) number(j) = t End If Next j Next i For i = 1 To 20 Print number(i) Next i End sub

7、首先定义一个数组：通过循环录入 10 个整数，然后用一个二重循环测试前一个数是否大于后一个数。如果大于则交换两个数的下标，即交换两个数在数组中的位置，交换通过一个变量来进行。 我先用传统的方法解决这个问题，经过比较，选用了较为简单的和高效的排序方法 “快速排序”，具体算法可参考数据结构等有关书籍。对所有数据排序后再合 并相同数据，合并程序较为简便，我开始时采用了这种方法，但后来发现对于这些 的数据，先合并后排序速度更快，因为有大量相同的数据。合并是采用“标记” 算 法，具体如下：（设数据已存放在 sData()数组中 ，结果存到 Queryp()数组， Amount 是数据个数） 把相同元素置

8、 0 For i = 1 To Amount If sData(i) IPmax Then IPmax = IntegerPart ElseIf IntegerPart DPmax Then DPmax = DecimalPart ElseIf DecimalPart 0 Then k = k 1 Queryp(k) = DiffDataArray(i, j) End If Next j Next i kMax = k ReDim Preserve Queryp(kMax) 该方法对于本人遇到的这种“密集型”数据最为有效，但是如果遇上“稀疏型” 数 据，例如最大、最小值相差几千，甚至上万的数据

9、，就没什么优势了，而且会占用 较大的内存。 经过改进，我得到了处理稀疏型数据的高效算法。高效的前提条件同样是源数据具 有大量相同数据。思路是在前一种方法的基础上增加一个单维数组，用来保存整数 部分数据，保存过程中用插入法对其进行排序。因为有大量重复数据，要排序的数 据量相对较少。当从二维数组中读取数据时，用单维数组代入二维数组的第一个下 标，具体代码下： 稀疏型数据处理 Dim i As Long, j As Long, k As Long, kMax As Long Dim Queryp() As Single ReDim Queryp(Amount) Dim IntegerPart As

10、Integer, DecimalPart As Integer Dim IPmax As Integer, IPmin As Integer Dim DPmax As Integer, DPmin As Integer Dim IPArray() As Integer, IPAamount As Integer ReDim IPArray(Amount) Dim DiffDataArray() 读取数据 ReadData IPmax = 0: IPmin = 1000 DPmax = 0: DPmin = 99 IPAamount = 0 For i = 1 To Amount 获取整数和小数

11、部分的最大最小值 IntegerPart = Int(sData(i) DecimalPart = (sData(i) IntegerPart) 100 If IntegerPart IPmax Then IPmax = IntegerPart ElseIf IntegerPart DPmax Then DPmax = DecimalPart ElseIf DecimalPart IPArray(j) Then IPAamount = IPAamount 1 For k = IPAamount To j 1 Step 1 IPArray(k) = IPArray(k 1) Next k IPA

12、rray(j) = IntegerPart Exit For ElseIf IntegerPart = IPArray(j) Then Exit For End If Next j If j IPAamount Then IPAamount = IPAamount 1 IPArray(IPAamount) = IntegerPart End If Next i ReDim DiffDataArray(IPmin To IPmax, DPmin To DPmax) 填入数据 For i = 1 To Amount IntegerPart = Int(sData(i) DecimalPart =

13、(sData(i) IntegerPart) 100 DiffDataArray(IntegerPart, DecimalPart) = sData(i) Next i 提取数据 k = 0 For i = 1 To IPAamount For j = DPmax To DPmin Step 1 If DiffDataArray(IPArray(i), j) “ Then Rows(i).Hidden = false Next i End Sub 用 VBA 如何自动合并列的内容？ 用 VBA 如何自动合并列的内容？ To hongjian ： Sub MergeTest() For i =

14、3 To 30 Cells(i, 3) = Cells(i, 1) & Chr(10) & Cells(i, 2) Next End Sub 基于 VB 和 EXCEL 的报表设计及打印 在现代管理信息系统的开发中，经常涉及到数据信息的分析、加工， 最终还需把统计结果形成各种形式的报表提供给领导决策参考，或进行外 部交流。在 Visual Basic 中制作报表，通常是用数据环境设计器(Data Environment Designer)与数据报表设计器(Data Report Designer),或者 使用第三方产品来完成。但对于大多数习惯于 Excel 报表的用户而言, 用以 上方法生成的

15、报表在格式和功能等方面往往不能满足他们的要求。 由于 Excel 具有自己的对象库，在 Visual Basic 工程中可以加以引用， 通过对 Excel 使用 OLE 自动化，可以创建一些外观整洁的报表，然后打印输 出。这样实现了 Visual Basi 应用程序对 Excel 的控制。本文将针对一个具 体实例，阐述基于 VB 和 EXCEL 的报表设计及打印过程。 1）创建 Excel 对象 Excel 对象模型包括了 128 个不同的对象，从矩形、文本框等简单的对 象到透视表，图表等复杂的对象。下面简单介绍一下其中最重要，也是用 得最多的五个对象。 （1）Application 对象 A

16、pplication 对象处于 Excel 对象层次结构的顶层，表示 Excel 自身的 运行环境。 （2）Workbook 对象 Workbook 对象直接地处于 Application 对象的下层，表示一个 Excel 工 作薄文件。 （3）Worksheet 对象 Worksheet 对象包含于 Workbook 对象，表示一个 Excel 工作表。 （4）Range 对象 Range 对象包含于 Worksheet 对象，表示 Excel 工作表中的一个或多个 单元格。 （5）Cells 对象 Cells 对象包含于 Worksheet 对象，表示 Excel 工作表中的一个单元格。

17、如果要启动一个 Excel，使用 Workbook 和 Worksheet 对象，下面的代码 启动了 Excel 并创建了一个新的包含一个工作表的工作薄： Dim zsbexcel As Excel.Application Set zsbexcel = New Excel.Application zsbexcel.Visible = True 如要 Excel 不可见，可使 zsbexcel.Visible = False zsbexcel.SheetsInNewWorkbook = 1 Set zsbworkbook = zsbexcel.Workbooks.Add 2）设置单元格和区域值

18、要设置一张工作表中每个单元格的值，可以使用 Worksheet 对象的 Range 属性或 Cells 属性。 With zsbexcel.ActiveSheet .Cells(1, 2).value = “100“ .Cells(2, 2).value = “200“ .Cells(3, 2).value = “=SUM(B1:B2)“ .Range(“A3:A9“) = “中国人民解放军“ End With 要设置单元格或区域的字体、边框，可以利用 Range 对象或 Cells 对象 的 Borders 属性和 Font 属性： With objexcel.ActiveSheet.Ran

19、ge(“A2:K9“).Borders 边框设置 .LineStyle = xlBorderLineStyleContinuous .Weight = xlThin .ColorIndex = 1 End With With objexcel.ActiveSheet.Range(“A3:K9“).Font 字体设置 .Size = 14 .Bold = True .Italic = True .ColorIndex = 3 End With 通过对 Excel 单元格和区域值的各种设置的深入了解,可以创建各种复 杂、美观、满足需要的、具有自己特点的报表。 3）预览及打印 生成所需要的工作表后，

20、就可以对 EXCEL 发出预览、打印指令了。 zsbexcel.ActiveSheet.PageSetup.Orientation = xlPortrait 设置打印方向 zsbexcel.ActiveSheet.PageSetup.PaperSize = xlPaperA4 设置打印纸的打下 zsbexcel.Caption = “打印预览“ 设置预览窗口的 标题 zsbexcel.ActiveSheet.PrintPreview 打印预览 zsbexcel.ActiveSheet.PrintOut 打印输出 通过打印方向、打印纸张大小的设置，不断进行预览，直到满意为止， 最终进行打印输出。

21、 为了在退出应用程序后 EXCEL 不提示用户是否保存已修改的文件,需使 用如下语句： zsbexcel.DisplayAlerts = False zsbexcel.Quit 退出 EXCEL zsbexcel.DisplayAlerts = True 如此设计的报表打印是通过 EXCEL 程序来后台实现的。对于使用者来 说，根本看不到具体过程，只看到一张张漂亮的报表轻易地被打印出来了。 4）具体实例 下面给出一个具体实例，它在 window98、Visual Basic 6.0、 Microsoft Office97 的环境下调试通过。 在 VB 中启动一个新的 Standard EXE

22、工程，在“工程”菜单的“ 引用” 选项下引用 Excel Object Library；然后在 Form 中添加一个命令按钮 cmdExcel；最后在窗体中输入如下代码： Dim zsbexcel As Excel.Application Private Sub cmdExcel_Click() Set zsbexcel = New Excel.Application zsbexcel.Visible = True zsbexcel.SheetsInNewWorkbook = 1 Set zsbworkbook = zsbexcel.Workbooks.Add With zsbexcel.Ac

23、tiveSheet.Range(“A2:C9“).Borders 边框设置 .LineStyle = xlBorderLineStyleContinuous .Weight = xlThin .ColorIndex = 1 End With With zsbexcel.ActiveSheet.Range(“A3:C9“).Font 字体设置 .Size = 14 .Bold = True .Italic = True .ColorIndex = 3 End With zsbexcel.ActiveSheet.Rows.HorizontalAlignment = xlVAlignCenter 水

24、平居中 zsbexcel.ActiveSheet.Rows.VerticalAlignment = xlVAlignCenter 垂直居中 With zsbexcel.ActiveSheet .Cells(1, 2).value = “100“ .Cells(2, 2).value = “200“ .Cells(3, 2).value = “=SUM(B1:B2)“ .Cells(1, 3).value = “中国人民解放军 “ .Range(“A3:A9“) = “50“ End With zsbexcel.ActiveSheet.PageSetup.Orientation = xlPort

25、rait xlLandscape zsbexcel.ActiveSheet.PageSetup.PaperSize = xlPaperA4 zsbexcel.ActiveSheet.PrintOut zsbexcel.DisplayAlerts = False zsbexcel.Quit zsbexcel.DisplayAlerts = True Set zsbexcel = Nothing 提高 EXCEL 中 VBA 的效率 方法 1：尽量使用 VBA 原有的属性、方法和 Worksheet 函数 由于 Excel 对象多达百多个，对象的属性、方法、事件多不胜数，对于初学者来说可能对它们不

26、全部了解，这就产生了编程者经常编写与 Excel 对象的属性、方法相同功能的 VBA 代码段，而这些代码段的运行效率显然与 Excel 对象的属性、方法完成任务的速度相差甚大。例如用 Range 的属性 CurrentRegion 来返回 Range 对象，该对象代表当前区。 （当前区指以任意空白行及空白列的组合为边界的区域） 。同样功能的 VBA 代码需数十行。因此编程前应尽可能多地了解 Excel 对象的属性、方法。 充分利用 Worksheet 函数是提高程序运行速度的极度有效的方法。如求平均工资的例子：For Each c In Worksheet(1).Range(A1:A1000)

27、 Totalvalue = Totalvalue c.value Next Averagevalue = Totalvalue / Worksheet(1).Range(A1:A1000).Rows.Count 而下面代码程序比上面例子快得多： Averagevalue=Application.WorksheetFunction.Average(Worksheets(1).Range(A1:A1000) 其它函数如 Count,Counta,Countif,Match,Lookup 等等，都能代替相同功能的 VBA 程序代码，提高程序的运行速度。 方法 2：尽量减少使用对象引用，尤其在循环中

28、每一个 Excel 对象的属性、方法的调用都需要通过 OLE 接口的一个或多个调用，这些 OLE 调用都是需要时间的，减少使用对象引用能加快 VBA 代码的运行。例如 1使用 With 语句。 Workbooks(1).Sheets(1).Range(A1:A1000).Font.Name=Pay Workbooks(1).Sheets(1).Range(A1:A1000).Font.FontStyle=Bold . 则以下语句比上面的快 With Workbooks(1).Sheets(1).Range(A1:A1000).Font .Name = Pay .FontStyle = Bold

29、 . End With 2使用对象变量。 如果你发现一个对象引用被多次使用，则你可以将此对象用 Set 设置为对象变量，以减少对对象的访问。如： Workbooks(1).Sheets(1).Range(A1).value = 100 Workbooks(1).Sheets(1).Range(A2).value = 200 则以下代码比上面的要快： Set MySheet = Workbooks(1).Sheets(1) MySheet.Range(A1).value = 100 MySheet.Range(A2).value = 200 3在循环中要尽量减少对象的访问。 For k = 1

30、To 1000 Sheets(Sheet1).Select Cells(k,1).value = Cells(1,1).value Next k 则以下代码比上面的要快： Set Thevalue = Cells(1,1).value Sheets(Sheet1).Select For k = 1 To 1000 Cells(k,1).value = Thevalue Next k 方法 3：减少对象的激活和选择 如果你的通过录制宏来学习 VBA 的，则你的 VBA 程序里一定充满了对象的激活和选择，例如Workbooks(XXX).Activate、Sheets(XXX).Select、Ra

31、nge(XXX).Select 等,但事实上大多数情况下这些操作不是必需的。例如 Sheets(Sheet3).Select Range(A1).value = 100 Range(A2).value = 200 可改为： With Sheets(Sheet3) .Range(A1).value = 100 .Range(A2).value = 200 End With 方法 4：关闭屏幕更新 如果你的 VBA 程序前面三条做得比较差，则关闭屏幕更新是提高 VBA 程序运行速度的最有效的方法，缩短运行时间 2/3 左右。关闭屏幕更新的方法： Application.ScreenUpdate =

32、 False 请不要忘记 VBA 程序运行结束时再将该值设回来： Application.ScreenUpdate = True 以上是提高 VBA 运行效率的比较有效的几种方法 本示例重复最近用户界面命令。本示例必须放在宏的第一行。 Application.Repeat 下例中，变量 counter 代替了行号。此过程将在单元格区域 C1:C20 中循环，将所有绝对值小于 0.01 的数字都设置为 0（零） 。 Sub RoundToZero1() For Counter = 1 To 20 Set curCell = Worksheets(“Sheet1“).Cells(Counter,

33、3) If Abs(curCell.Value) 0 Then Application.ActivePrinter = “zdserver2HP LaserJet 5000 PCL 6 在 Ne00:“ 指定打印机 ActiveWindow.SelectedSheets.PrintOut Copies:=myPrintNum, Collate:=True 设置打印信息,其中 Copies:=myPrint 为打印份数 Else MsgBox “请输入要打印的份数 “ End If ActiveSheet.ShowAllData 全部显示 ActiveSheet.Protect Password

34、:=641112 保护工作表并设置密码 Sheets(“封面“).Select Application.ScreenUpdating = True End Sub Sub 打印余额() Application.ScreenUpdating = False Sheets(“余额表 “).Select Call 重算所有表 ActiveSheet.Unprotect Password:=641112 撤消工作表保护并取消密码 ActiveWindow.ScrollColumn = 10 Selection.AutoFilter Field:=1, Criteria1:=“ 0 Then Appli

35、cation.ActivePrinter = “zdserver2HP LaserJet 5000 PCL 6 在 Ne00:“ 指定打印机 ActiveWindow.SelectedSheets.PrintOut Copies:=myPrintNum, Collate:=True 设置打印信息,其中 Copies:=myPrint 为打印份数 Else MsgBox “请输入要打印的份数 “ End If ActiveSheet.ShowAllData 全部显示 ActiveSheet.Protect Password:=641112 保护工作表并设置密码 Sheets(“封面“).Sele

36、ct Application.ScreenUpdating = True End Sub Sub 备份() Dim y 变量声明 -需保存工作表的路径和名称 M1 = ActiveWorkbook.FullName 单元格 M1=当前工作簿的路径和名称 y = cells(1, 14) Y=单元格 N1 的值,即计算后的需保存工作簿的路径和名称 Worksheets(“封面“).UsedRange.Columns(“M:N“).Calculate 计算指定区域 ActiveWorkbook.SaveCopyAs y 备份到指定路么 Y End Sub Sub 重算活动表() With Appl

37、ication .Calculation = xlManual .MaxChange = 0.001 End With ActiveWorkbook.PrecisionAsDisplayed = True ActiveWindow.DisplayZeros = True ActiveSheet.Calculate End Sub Sub 重算指定表() Attribute 重算指定表.VB_ProcData.VB_Invoke_Func = “zn14“ Worksheets(“银行帐“).Calculate Worksheets(“日报表“).Calculate End Sub 单元格数据改

38、变引起计算激活过程 Private Sub Worksheet_Change(ByVal Target As Range) Dim irow, icol As Integer irow = Target.Row 变量行 irow icol = Target.Column 变量列 icol If irow 6 And icol = 3 And cells(irow, 3) = cells(irow - 1, 3) Then 大于 6 行,并且第 3 列,当本行 3 列2 行 3 列 Application.EnableEvents = False cells(irow, 2) = cells(i

39、row - 1, 2) 本行 2 列=上一行 2 列 Application.EnableEvents = True ElseIf irow 6 And icol = 3 And cells(irow, 3) 大于 6 行, 并且第 3列,当本行 3 列2 行 3 列 Application.EnableEvents = False cells(irow, 2) = cells(irow - 1, 2) + 1 本行 2 列= 上行 2 列+1 Application.EnableEvents = True ElseIf (icol = 3 Or icol = 4 Or icol = 6 Or

40、 icol = 8 Or icol = 9 Or icol = 10 Or icol = 12 Or icol = 13) And irow 6 Then And Target “ Application.EnableEvents = False cells(irow, 5) = “=单位名称“ cells(irow, 7) = “=摘要“ cells(irow, 11) = “=余额“ Range(cells(irow, 14), cells(irow, 16) = “=预内外收支 NOP“ cells(irow, 17) = “=审核 Q“ cells(irow, 18) = “=对帐 U

41、“ Range(cells(irow, 19), cells(irow, 20) = “=内转收支 XY“ cells(irow, 21) = “=政采 Z“ Application.EnableEvents = True End If End Sub 计算当前工作表路径及名称的函数, 可作为单元格公式,也可写入宏 =CELL(“FILENAME“) 改变 Excel 界面标题的宏 Private Sub Workbook_Open() Application.Caption = “吃过了“ End Sub 自动刷新单元格 A1 内显示的日期时间的宏 Sub mytime() Range(“a

42、1“) = Now() Application.OnTime Now + TimeValue(“00:00:01“), “mytime“ End Sub 用单元格 A1 的内容作为文件名保存当前工作簿的宏 Sub b() ActiveWorkbook.SaveCopyAs Range(“A1“) + “.xls“ End Sub 激活窗体的宏, 此宏写入有窗体的工作表内 Private Sub CommandButton1_Click() 点数据录入按钮控件激活窗体 Load UserForm3 激活窗体 UserForm3.StartUpPosition = 3 激活窗体 UserForm3.Show 激活窗体 End Sub 以下为窗体中点击各按钮运行的宏, 写入窗体内 Public pos As Integer 声明变量 pos 战友确定按钮语句 Private Sub CommandButton1_Click() B