EXCel+VBA经典应用.doc

EXCel VBA经典应用例子显示工作表名字的函数=CELL(filename,Examples!D22)VBScript编码约定 出于易读和一致性的目的，请在 VBScript 代码中使用以下变量命名约定： 子类型 前缀 示例 Boolean bln blnFound Byte byt bytRasterData Date (Time) dtm dtmStart Double dbl dblTolerance Error err errOrderNum Integer int intQuantity Long lng lngDistance Object obj objCurrent Single sng sngAverage String str strFirstName 变量作用域变量应定义在尽量小的作用域中。VBScript 变量的作用域如下所示： 作用域 声明变量处 可见性 过程级 事件、函数或子过程 在声明变量的过程中可见 Script 级 HTML 页面的 HEAD 部分，任何过程之外 在 Script 的所有过程中可见 变量作用域前缀随着 Script 代码长度的增加，有必要快速区分变量的作用域。在类型前缀前面添加一个单字符前缀可以实现这一点，而不致使变量名过长。 作用域 前缀 示例 过程级 无 dblVelocity Script 级 s sblnCalcInProgress 描述性变量名和过程名变量名或过程名的主体应使用大小写混合格式，并且尽量完整地描述其目的。另外，过程名应以动词开始，例如 InitNameArray 或 CloseDialog。 对于经常使用的或较长的名称，推荐使用标准缩写以使名称保持在适当的长度内。通常多于 32 个字符的变量名会变得难以阅读。使用缩写时，应确保在整个 Script 中保持一致。例如，在一个 Script 或 Script 集中随意切换 Cnt 和 Count 将造成混乱。 对象命名约定下表列出了 VBScript 中可能用到的对象命名约定（推荐）： 对象类型 前缀 示例 3D 面板 pnl pnlGroup 动画按钮 ani aniMailBox 复选框 chk chkReadOnly 组合框、下拉列表框 cbo cboEnglish 命令按钮 cmd cmdExit 公共对话框 dlg dlgFileOpen 框架 fra fraLanguage 水平滚动条 hsb hsbVolume 图像 img imgIcon 标签 lbl lblHelpMessage 直线 lin linVertical 列表框 lst lstPolicyCodes 旋钮 spn spnPages 文本框 txt txtLastName 垂直滚动条 vsb vsbRate 滑块 sld sldScale 代码注释约定所有过程的开始部分都应有描述其功能的简要注释。这些注释并不描述细节信息（如何实现功能），这是因为细节有时要频繁更改。这样就可以避免不必要的注释维护工作以及错误的注释。细节信息由代码本身及必要的内部注释来描述。 当传递给过程的参数的用途不明显，或过程对参数的取值范围有要求时，应加以说明。如果过程改变了函数和变量的返回值（特别是通过参数引用来改变），也应在过程的开始部分描述该返回值。 过程开始部分的注释应包含以下区段标题。相关样例，请参阅后面的“格式化代码”部分。 区段标题 注释内容 目的 过程的功能（不是实现功能的方法）。 假设 其状态影响此过程的外部变量、控件或其他元素的列表。 效果 过程对每个外部变量、控件或其他元素的影响效果的列表。 输入 每个目的不明显的参数的解释。每个参数都应占据单独一行并有其内部注释。 返回 返回值的解释。注册表中的excel配置信息 add_in manager 列出工具加载宏的列表autoSave 保存设置的自动保存选项Converters 外部的文件转换程序Delete Commands 允许指定不想出现哪个菜单命令Error Checking 保存公式错误检查方面的设置Init Commands 保存自定义命令方面的信息Init Menus 保存自定义菜单方面的信息Line Print 保存1-2-3宏打印用到的位置Options 这是一个全捕捉小节Recent Files 最近保存的文件的名称Recent Templates 最近使用的模板名称Resiliency 用于恢复文档的信息Security 指定打开包含宏的文件时的安全级Spell Checker 拼写检查选项的信息UserInfo 有关用户的信息Excel 2000 VBA删除VBA模块代码 With ActiveWorkbook.VBProject .VBComponents.Remove .VBComponents(module1) End With 以上代码在excel2002 及更高版本不能运行页眉打印完整工作簿路径和文件名 Private Sub Workbook_BeforePrint(Cancel As Boolean) For Each sht In ThisWorkbook.Sheets sht.PageSetup.LeftHeader = ThisWorkbook.FullName Next sht End Sub个人信息个性设置excel保存位置 *.xlb 如excel出现问题,可以将*.xlb文件删掉,再重新启动excel即可excel中播放声音代码 Private Sub Workbook_Open() Application.Speech.Speak (hello & Application.UserName) End Sub巧用数据有效性快速输入数据 大家知道，利用Excel数据菜单中的有效性功能可以控制一个范围内的数据类型、范围等，其实利用它还可以快速、准确地输入一些数据。比如我们需要在下表A2:A12区域输入班级的名称，而其名称“初三1班、初三2班、初三3班”又是固定的内容。在这种情况下利用数据的有效性，便可将班级快速且准确无误地输入进去，具体的步骤如下： 1. 先在一个空白区域内输入好序列：“初三1班、初三2班、初三3班”，如表中“G3:G5”区域。 2. 选中要输入数据的区域，如选中“A2:A12”。 3. 依次选择“数据有效性”菜单命令，打开“数据有效性”对话框。在这里设置有效性条件为“序列”，选中“提供下拉箭头”。并在来源里选择序列区域“G3:G5”，单击“确定”按钮。 4. 把光标放在需要输入数据的单元格内，此时便会有一个下拉箭头，按下“Alt+”，在弹出的下拉列表中选择需要的数据，按回车键即可。 怎么样，如果数据很多的话，比逐个输入要方便的多吧，此例仅在说明其用法，希望大家能在实际工作中触类旁通。 以上转自:太平洋学院 另: 在不同表引用有效性数据,必须用名称方式即可 如:1.定义名称 2.在数据有效性 =名称 即可实现在不同表引用有效性数据还有一个方法，就是使用函数indirect如：在数据有效性=indirect(sheet2!g3:g5)爱好者 2007-08-10 09:54我上面举的例子中的反斜杠符号是这里的网页加上去的，应去掉这两个符号。 共:3条记录 将excel数据导出为xml 将excel数据导出为xmlSub ExportToXML() Dim ws As Worksheet Dim Filename As Variant Dim TDOpenTag As String, TDCloseTag As String Dim CellContents As String Dim Rng As Range Dim r As Long, c As Integer Set the range Set Rng = Range(A1:L11) Get a file name Filename = Application.GetSaveAsFilename( _ InitialFileName:=myrange.xml, _ fileFilter:=XML Files(*.xml), *.xml) If Filename = False Then Exit Sub Open the text file Open Filename For Output As #1 Write the tag Print #1, Print #1, Loop through the cells For r = 2 To Rng.Rows.Count Print #1, For c = 1 To Rng.Columns.Count Print #1, ; If IsDate(Rng.Cells(r, c) Then Print #1, Format(Rng.Cells(r, c), yyyy-mm-dd); Else Print #1, Rng.Cells(r, c).Text; End If Print #1, Next c Print #1, Next r Close the table Print #1, Close the file Close #1 Tell the user MsgBox Rng.Rows.Count - 1 & records were exported to & FilenameEnd Sub将数据导出为html 将数据导出为htmlOption ExplicitSub ExportToHTML() Dim ws As Worksheet Dim Filename As Variant Dim TDOpenTag As String, TDCloseTag As String Dim CellContents As String Dim Rng As Range Dim r As Long, c As Integer Use the selected range of cells Set Rng = Application.Intersect(ActiveSheet.UsedRange, Selection) Get a file name Filename = Application.GetSaveAsFilename( _ InitialFileName:=myrange.htm, _ fileFilter:=HTML Files(*.htm), *.htm) If Filename = False Then Exit Sub Open the text file Open Filename For Output As #1 Write the tag Print #1, Loop through the cells For r = 1 To Rng.Rows.Count Print #1, For c = 1 To Rng.Columns.Count TDOpenTag = TDCloseTag = If Rng.Cells(r, c).Font.Bold Then TDOpenTag = TDOpenTag & TDCloseTag = & TDCloseTag End If If Rng.Cells(r, c).Font.Italic Then TDOpenTag = TDOpenTag & TDCloseTag = & TDCloseTag End If CellContents = Rng.Cells(r, c).Text Print #1, TDOpenTag & CellContents & TDCloseTag Next c Print #1, Next r Close the table Print #1, Close the file Close #1 Tell the user MsgBox Rng.Count & cells exported to & FilenameEnd Sub将数据导出为txt文件 将数据导出为txt文件Option ExplicitSub ExportRange() Dim Filename As String Dim NumRows As Long, NumCols As Integer Dim r As Long, c As Integer Dim Data Dim ExpRng As Range Set ExpRng = Selection NumCols = ExpRng.Columns.Count NumRows = ExpRng.Rows.Count Filename = c:textfile.txt Open Filename For Output As #1 For r = 1 To NumRows For c = 1 To NumCols Data = ExpRng.Cells(r, c).Value If IsNumeric(Data) Then Data = Val(Data) If IsEmpty(ExpRng.Cells(r, c) Then Data = If c NumCols Then Write #1, Data; Else Write #1, Data End If Next c Next r Close #1End SubSub ImportRange() Dim ImpRng As Range Dim Filename As String Dim r As Long, c As Integer Dim txt As String, Char As String * 1 Dim Data Dim i As Integer Set ImpRng = ActiveCell On Error Resume Next Filename = c:windowsdesktoptextfile.txt Open Filename For Input As #1 If Err 0 Then MsgBox Not found: & Filename, vbCritical, ERROR Exit Sub End If r = 0文件操作代码 文件操作代码Option ExplicitSub DoesFileExist() Dim path As String Dim FileName As String Dim FileSpec As String path = Application.InputBox(Enter the directory:) If path = Then Exit Sub FileName = Application.InputBox(Enter the file name:) If FileName = Then Exit Sub If Right(path, 1) Then path = path & FileSpec = path & FileName MsgBox Using VBA command. & vbCrLf & vbCrLf & FileExists1(FileSpec), vbInformation, FileSpec MsgBox Using FileSearch object. & vbCrLf & vbCrLf & FileExists2(path, FileName), vbInformation, FileSpec MsgBox Using FileSystemObject object. & vbCrLf & vbCrLf & FileExists3(FileSpec), vbInformation, FileSpecEnd SubFunction FileExists1(fname) As Boolean Uses VBA command FileExists1 = Dir(fname) End FunctionFunction FileExists2(path, fname) As Boolean Uses FileSerach object With Application.FileSearch .NewSearch .FileName = fname .LookIn = path .Execute FileExists2 = .FoundFiles.Count = 1 End WithEnd FunctionFunction FileExists3(fname) As Boolean Dim FileSys As Object Set FileSys = CreateObject(Scripting.FileSystemObject) FileExists3 = FileSys.FileExists(fname)End Function显示工作表项目 显示工作表项目Sub ShowComponents() Make sure access to the VBProject is allowed On Error Resume Next Set x = ActiveWorkbook.VBProject If Err 0 Then MsgBox Your security settings do not allow this macro to run., vbCritical On Error GoTo 0 Exit Sub End If Dim VBP As VBIDE.VBProject Set VBP = ActiveWorkbook.VBProject NumComponents = VBP.VBComponents.Count Cells.ClearContents For i = 1 To NumComponents Name Cells(i, 1) = VBP.VBComponents(i).Name Type Select Case VBP.VBComponents(i).Type Case 1 Cells(i, 2) = Module Case 2 Cells(i, 2) = Class Module Case 3 Cells(i, 2) = UserForm Case 100 Cells(i, 2) = Document Module End Select Lines of code Cells(i, 3) = VBP.VBComponents(i).CodeModule.CountOfLines Next iEnd Sub替换工作表模块 替换工作表模块Sub UpdateUserBook() Filename = UserBook.xls Make sure access to the VBProject is allowed On Error Resume Next Set x = ActiveWorkbook.VBProject If Err 0 Then MsgBox Your security settings do not allow this macro to run., vbCritical On Error GoTo 0 Exit Sub End If Activate workboook On Error Resume Next Workbooks(Filename).Activate If Err 0 Then MsgBox Filename & must be open!, vbCritical Exit Sub End If Msg = This macro will replace Module1 in UserBook.XLS Msg = Msg & with an updated Module. & vbCrLf & vbCrLf Msg = Msg & Click OK to continue. If MsgBox(Msg, vbInformation + vbOKCancel) = vbOK Then Call ReplaceModule Else MsgBox Module not replaced!, vbCritical End IfEnd SubSub ReplaceModule() Export Module1 from this workbook Filename = ThisWorkbook.Path & tempmodxxx.bas ThisWorkbook.VBProject.VBComponents(Module1) _ .Export Filename Replace Module1 in UserBook Set VBP = ActiveWorkbook.VBProject On Error GoTo ErrHandle With VBP.VBComponents .Remove VBP.VBComponents(Module1) .Import Filename End With Delete the temorary module file Kill Filename MsgBox The module has been replaced., vbInformation Exit SubErrHandle: Did an error occur? MsgBox ERROR. The module may not have been replaced., _ vbCriticalEnd Sub控制窗体属性 控制窗体属性Option ExplicitPassed back to the function from the UserFormPublic GETOPTION_RET_VAL As VariantFunction GetOption(OpArray, Default, Title) Dim TempForm As Object VBComponent Dim NewOptionButton As Msforms.OptionButton Dim NewCommandButton1 As Msforms.CommandButton Dim NewCommandButton2 As Msforms.CommandButton Dim i As Integer, TopPos As Integer Dim MaxWidth As Long Dim Code As String Hide VBE window to prevent screen flashing Application.VBE.MainWindow.Visible = False Create the UserForm Set TempForm = _ ThisWorkbook.VBProject.VBComponents.Add(3) vbext_ct_MSForm TempForm.Properties(Width) = 800 Add the OptionButtons TopPos = 4 MaxWidth = 0 Stores width of widest OptionButton For i = LBound(OpArray) To UBound(OpArray) Set NewOptionButton = TempForm.Designer.Controls. _ Add(forms.OptionButton.1) With NewOptionButton .Width = 800 .Caption = OpArray(i) .Height = 15 .Left = 8 .Top = TopPos .Tag = i .AutoSize = True If Default = i Then .Value = True If .Width MaxWidth Then MaxWidth = .Width End With TopPos = TopPos + 15 Next i Add the Cancel button Set NewCommandButton1 = TempForm.Designer.Controls. _ Add(forms.CommandButton.1) With NewCommandButton1 .Caption = Cancel .Height = 18 .Width = 44 .Left = MaxWidth + 12 .Top = 6 End With Add the OK button Set NewCommandButton2 = TempForm.Designer.Controls. _ Add(forms.CommandButton.1) With NewCommandButton2 .Caption = OK .Height = 18 .Width = 44 .Left = MaxWidth + 12 .Top = 28 End With Add event-hander subs for the CommandButtons Code = Code = Code & Sub CommandButton1_Click() & vbCrLf Code = Code & GETOPTION_RET_VAL=False & vbCrLf Code = Code & Unload Me & vbCrLf Code = Code & End Sub & vbCrLf Code = Code & Sub CommandButton2_Click() & vbCrLf Code = Code & Dim ctl & vbCrLf Code = Code & GETOPTION_RET_VAL = False & vbCrLf Code = Code & For Each ctl In Me.Controls & vbCrLf Code = Code & If TypeName(ctl) = OptionButton Then & vbCrLf Code = Code & If ctl Then GETOPTION_RET_VAL = ctl.Tag & vbCrLf Code = Code & End If & vbCrLf Code = Code & Next ctl & vbCrLf Code = Code & Unload Me & vbCrLf Code = Code & End Sub With TempForm.CodeModule .InsertLines .CountOfLines + 1, Code End With Adjust the form With TempForm .Properties(Caption) = Title .Properties(Width) = NewCommandButton1.Left + _ NewCommandButton1.Width + 10 If .Properties(Width) 160 Then .Properties(Width) = 160 NewCommandButton1.Left = 106 NewCommandButton2.Left = 106 End If .Properties(Height) = TopPos + 24 End With Show the form VBA.UserForms.Add(TempForm.Name).Show Delete the form ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=TempForm Pass the selected option back to the calling procedure GetOption = GETOPTION_RET_VALEnd FunctionSub TestGetOption() Dim Ops(1 To 5) Dim UserOption Make sure access to the VBProject is allowed On Error Resume Next Dim x Set x = ActiveWorkbook.VBProject If Err 0 Then MsgBox Your security settings do not allow this macro to run., vbCritical On Error GoTo 0 Exit Sub End If Ops(1) = North Ops(2) = South Ops(3) = West Ops(4) = East Ops(5) = All Regions UserOption = GetOption(Ops, 5, Select a region) MsgBox Ops(UserOption)End SubSub TestGetOption2() Dim Ops() Dim UserOption, i, Cnt Make sure access to the VBProject is allowed On Error Resume Next Dim x Set x = ActiveWorkbook.VBProject If Err 0 Then MsgBox Your security settings do not allow this macro to run., vbCritical On Error GoTo 0 Exit Sub End If Cnt = Application.WorksheetFunction.CountA(Range(A:A) ReDim Ops(1 To Cnt) For i = 1 To Cnt Ops(i) = Cells(i, 1) Next i UserOption = GetOption(Ops, 0, Select a month) If UserOption = False Then Exit Sub Else MsgBox Ops(UserOption)End Sub设计按钮 设计按钮Sub RunTimeButton() Adds a button at runtime Make sure access to the VBProject is allowed On Error Resume Next Set x = ActiveWorkbook.VBProject If Err 0 Then MsgBox Your security settings do not allow this macro to run., vbCritical On Error GoTo 0 Exit Sub End If Dim Butn As CommandButton Set Butn = UserForm1.Controls.Add(Forms.CommandButton.1) With Butn .Caption = Added at runtime .Width = 100 .Top = 10 End With UserForm1.ShowEnd SubSub DesignTimeButton() Adds a button at design-time Make sure access to the VBProject is allowed On Error Resume Next Set x = ActiveWorkbook.VBProject If Err 0 Then MsgBox Your security settings do not allow this macro to run., vbCritical On Error GoTo 0 Exit Sub End If Dim Butn As CommandButton Set Butn = ThisWorkbook.VBProject.VBComponents(UserForm1) _ .Designer.Controls.Add(Forms.CommandButton.1) With Butn .Caption = Added at design-time .Width = 120 .Top = 40 End With VBA.UserForms.Add(UserForm1).ShowEnd Sub增加按钮和代码 增加按钮和代码Sub AddSheetAndButton() Dim NewSheet As Worksheet Dim NewButton As OLEObject Make sure access to the VBProject is allowed On Error Resume Next Set x = ActiveWorkbook.VBProject If Err 0 Then MsgBox Your security settings do not allow this macro to run., vbCritical On Error GoTo 0 Exit Sub End If Add the sheet Set NewSheet = Sheets.Add Add a CommandButton Set NewButton = NewSheet.OLEObjects.Add _ (Forms.CommandButton.1) With NewButton .Left = 4 .Top = 4 .Width = 100 .Height = 24 .Object.Caption = Return to Sheet1 End With Add the event handler code Code = Sub CommandButton1_Click() & vbCrLf Code = Code & On Error Resume Next & vbCrLf Code = Code & Sheets(Sheet1).Activate & vbCrLf Code = Code & If Err 0 Then & vbCrLf Code = Code & MsgBox Cannot activate Sheet1. & vbCrLf Code = Code & End If & vbCrLf Code = Code & End Sub With ActiveWorkbook.VBProject. _ VBComponents(NewSheet.Name).CodeModule NextLine = .CountOfLines + 1 .InsertLines NextLine, Code End WithEnd Sub增加100个按钮 Option ExplicitSub Add100Buttons()Dim UFvbc As Object VBComponentDim CMod As Object CodeModuleDim ctl As ControlDim cb As CommandButtonDim n As Integer, c As Integer, r As IntegerDim code As String Make sure access to the VBProject is allowed On Error Resume