Excel-VBA-编程难点-版主高手实例集锦.doc

1. ，常用的、带解释的 VBA 短句 by:yuhongpu/dispbbs.asp?boardID=2&ID=169024&page=1&px=0VBA起步常用的、带解释的 VBA 短句A65536.End(xlUp).Row A列末行向上第一个有值的行数A1.End(xlDown).Row A列首行向下第一个有值之行数IV1.End(xlToLeft).Column 第一行末列向左第一列有数值之列数。A1.End(xlToRight).Column 第一行首列向右有连续值的末列之列数Application.CommandBars(Standard).Controls(2).BeginGroup=True 在常用工具栏的第二个按钮前插入分隔符Cells.WrapText = False 取消自动换行 If Len(Target) 5 Then 如果当前单元格中的字符数超过5个,执行下一行 Target.WrapText = True 自动换行 End IfA1:B10.SpecialCells(xlCellTypeBlanks).Rows.Hidden = True 有空格即隐藏行A2. 返回活动单元格的工作表名A2. 返回活动单元格的工作簿名如下代码可使工作簿打开后30秒(或闲置30秒)内不输入、不重新选择等,自动关闭工作簿Private Sub Workbook_Open() 工作簿打开事件 tt 工作簿打开时启动 tt 过程End SubPrivate Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 工作表变化事件 tt 工作表中任一单元格有变化时启动 tt 过程End SubPrivate Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) 工作表选择变化事件 tt 工作表中单元格的选择有变化时启动 tt 过程End SubSub tt() tt 过程 Dim myNow As Date, BL As Integer 定义myNow为日期型;定义BL为长整型 myNow = Now 把当前的时间赋给变量myNow Do 开始循环语句Do BL = Second(Now) - Second(myNow) 循环中不断检查变量BL的值 If BL = 30 Then GoTo Cl 当BL=30即跳转到CL DoEvents 转让控制权,以便sheets可继续操作 Loop Until BL 30 当BL30即跳出循环 Exit SubCl: Application.EnableEvents = False 避免引起其他事件 ActiveWorkbook.Close True 关闭活动工作簿并保存 Application.EnableEvents = True 可触发其他事件End Subrange(e4).addcomment.Text 代头 & Chr(10) & 内容 添加批注 range(e4).Comment.Visible = True 显示批注把工作簿中所有工作表的指定列调整为最佳列宽：Sub 调整列宽() Dim i% For i = 1 To Sheets.Count 遍历工作簿中所有的工作表 Sheets(i).Columns(A:K).AutoFit 把每个工作表的A:K列调整为最佳列宽 Next i End SubDo循环语句的几种形式:1. Do While i1 条件为True时执行. . 要执行的语句Loop2.Do Until i1 条件为False时执行. . 要执行的语句Loop3.Do . . 要执行的语句Loop While i1 条件为True时执行4.Do . . 要执行的语句Loop Until i1 条件为False时执行5.While.Wend 语句While i1 条件为True时执行. . 要执行的语句Wend勾选VBA项目的信任Application.SendKeys %(tmstv)ENTER 在 Excel 窗口操作Application.SendKeys %(qtmstv)ENTER 在 VBE 窗口操作Application.CommandBars(命令按钮名称).Position = msoBarFloating 使命令按钮悬浮在表格中 Application.CommandBars(命令按钮名称).Position = msoBarTop 使命令按钮排列在工具栏中ActiveStect Password:=wshzw 为工作表保护加口令ActiveSheet.Unprotect Password:=wshzw 解除工作表保护Activesheet.ProtectContents 判断工作表是否处于保护状态工作表的复制与命名Sub wshzw() Dim i As Integer For i = 1 To 5 Sheets(Sheet1).Copy After:=Sheets(1) Before/After 复制新表在 Sheets(Sheet1) 前/后 ActiveSheet.Name = i & 月 为复制的新表命名 Next i Sheets(Sheet1).Name = 总表 为 Sheets(Sheet1) 改名End SubApplication.EnableEvents = False .Application.EnableEvents = True 抑制事件连锁执行Application.EnableEvents = FalseActiveWorkbook.Save 抑制BeforeSave事件的发生Application.EnableEvents = True 抑制指定事件Application.DisplayAlerts=False 屏蔽确认提示 Application.ScreenUpdating = False .Application.ScreenUpdating = true 冻结屏幕以加快程序运行 ActiveCell.CurrentRegion.Select 选择与活动单元格相连的区域range(a2:a20).NumberFormatLocal = 00-00 区域的格式化ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row 已用区域的最末行ActiveSheet.Copy Before:=Sheets(1) 复制活动工作表到第一张工作表之前range(a2:a20).FormulaHidden = True 工作表处于保护状态时隐藏部分单元格公式 FileDateTime(E:My Documents33.xls)或FileDateTime(thisworkbook.FullName) 文件被创建或最后修改后的日期和时间FileLen(thisworkbook.FullName) / 1024或FileLen(E:My Documentstemp33.xls) / 1024 文件的长度(大小),单位是 KBApplication.AskToUpdateLinks = False 不询问是否更新链接,并自动更新链接ActiveSheet.Hyperlinks.Delete 删除活动工作表超链接ActiveWorkbook.SaveLinkValues = False 不保存活动工作簿的外部链接值ActiveSheet.PageSetup.CenterFooter = Range(k2).Value 打印时设置自定义页脚ActiveSheet.PageSetup.Orientation = xlLandscape 设置为横向打印ActiveSheet.PageSetup.Orientation = xlPortrait 设置为纵向打印Application.WindowState = xlMinimized 最小化窗口 Application.WindowState = xlNormal 最大化窗口Sub 删除工作表() Application.DisplayAlerts = False Sheet1.Delete Application.DisplayAlerts = TrueEnd Sub有删除就有添加Sub 添加工作表() For i = 1 To 5 Worksheets.Add.Name = i NextEnd SubA1:A20.AdvancedFilter xlFilterCopy, B1, Unique:=True 可去掉重复数据A2:C32.Replace What:=F, Replacement:=G 指定范围内的查找与替换Activesheet.AutoFilterMode = false 取消自动筛选执行以下语句可有效缩小工作簿的大小，执行前请先看清每条语句的作用:ActiveSheet.UsedRange.Comment.Shape.TextFrame.AutoSize = True 根据批注内容自动调整大小ActiveSheet.UsedRange.ClearComments 清除活动工作表已使用范围所有批注ActiveSheet.UsedRange.ClearFormats 清除活动工作表已使用范围所有格式ActiveSheet.UsedRange.Validation.Delete 取消活动工作表已使用范围的数据有效性ActiveSheet.Hyperlinks.Delete 删除活动工作表超链接ActiveSheet.DrawingObjects.Delete 删除活动工作表已使用范围的所有对象ActiveSheet.UsedRange = ActiveSheet.UsedRange.Value 取消活动工作表已使用范围的公式并保留值还有：Sub x() Dim myRange As String myRange = ActiveSheet.UsedRange.Address 去除活动工作表无数据的行列End SubActiveWorkbook.FullName 当前窗口文件名与路径Application.AltStartupPath= E:MyMyStart 替补启动目录路径Application.AutoRecover.Path 返回/设置Excel存储自动恢复临时文件的完整路径Application.DefaultFilePath 选项常规中的默认工作目录Application.Evaluate(=INFO(directory) 默认工作目录Application.LibraryPath 返回库文件夹的路径Application.NetworkTemplatesPath 返回保存模板的网络路径Application.Path 返回应用程序完整路径Application.RecentFiles.Item(1).Path 返回最近使用的某个文件路径,Item(1)=第一个文件Application.StartupPath Excel启动文件夹的路径Application.TemplatesPath 返回模板所存储的本地路径Application.UserLibraryPath 返回用户计算机上 COM 加载宏的安装路径Debug.Print Application.PathSeparator 路径分隔符 CurDir 默认工作目录Excel.Parent.DefaultFilePath 默认工作目录ThisWorkbook.Path 返回当前工作薄的路径dim mm(2,10)Range(a1:b10)=mm 可以将二维数组赋值给RangeApplication.Dialogs(XLdialogsaveas).show 显示保存对话框SIZE=1Sub x() Dim myRange As String myRange = ActiveSheet.UsedRange.Address 去除活动工作表无数据的行列End Sub这相当于把新的已使用区域赋值给变量，效果等同于手工删除多余的列或行后立即保存;来一个函数的Private Sub Worksheet_SelectionChange(ByVal Target As Range)右边单元格反向显示活动单元格文本If ActiveCell.Column 100, Operator:=xlAnd, _ Criteria2:=200 Windows(Mybo).Worksheets(She).Range(A1:K5000).Copy _ Destination:=Windows(mybook).Worksheets(acfmis).Range(A1)2. 选择变色 by:Lht7777/dispbbs.asp?boardID=1&ID=222901&page=1&px=0选中B3时，B1A3变红色；选中C4时，C1A4变黄色Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Count = 1 Then If Target.Address = $B$3 Then Range(b1,a3).Interior.ColorIndex = 3 Else Range(b1,a3).Interior.ColorIndex = xlautocolor End If If Target.Address = $C$4 Then Range(c1,a4).Interior.ColorIndex = 6 Else Range(c1,a4).Interior.ColorIndex = xlautocolor End IfEnd IfEnd Sub3. 工作表权限 by:fieldsun /dispbbs.asp?BoardID=1&ID=72744&replyID=&skin=0Private Sub Worksheet_Change(ByVal Target As Range)Dim c As RangeIf Target.Address = $F$1 ThenApplication.ScreenUpdating = FalseFor Each c In Range(A2:A21)Sheets(c.Value).Visible = c.Offset(0, Range(G1).Value).ValueNext cApplication.ScreenUpdating = TrueEnd IfEnd SubBy: andysky/viewthread.php?tid=372297&extra=page%3D1Private Sub Workbook_SheetActivate(ByVal Sh As Object)Dim a As Bytea = ActiveSheet.IndexIf a 4 ThenIf InputBox(密码:, 请确认密码, 4) = a ThenSheets(a).SelectElseSheets(4).SelectEnd IfEnd IfEnd Sub4. 浮动按钮 by:Qee用/dispbbs.asp?boardid=5&id=13551&star=1#63383Private Sub Worksheet_SelectionChange(ByVal Target As Range) Button.Top = Target.TopEnd SubSub Fill10()自动填充十行 Dim rg As Range Application.EnableEvents = False For Each rg In Selection rg.Resize(11, 1) = rg Next rg Application.EnableEvents = TrueEnd Sub5. 导出到文本文件 by:chenimbile/dispbbs.asp?boardid=5&id=13772&star=1#65435Private Sub CommandButton1_Click()Dim filesavename As StringDim str2 As StringDim x As IntegerDim maxrow As Integerfilesavename = Application.GetSaveAsFilename( _InitialFileName:=d:, fileFilter:=Text Files (*.txt), *.txt) 选择文件Set fs = CreateObject(Scripting.FileSystemObject)Set a = fs.CreateTextFile(filesavename, True)maxrow = Range(e65535).End(xlUp).RowFor x = 4 To maxrow str2 = Range(e & x).Value & , & Range(f & x).Value If x = maxrow Then a.write (str2) 最后一行，系统自动加回车换行符，(Chr(13) + Chr(10) Else a.writeline (str2) End IfNexta.CloseEnd Sub6. 合并删除单元格(定时设置) by:sjzhouzbPrivate Sub CommandButton1_Click()by: sjzhouab但是只是删除了前面的，与题意有些不同t = TimerApplication.ScreenUpdating = FalseFor i = 1 To a65536.End(xlUp).Row If Range(a & i) And Range(a & i) 序 号 And Range(a & i) 分部分项工程量清单综合单价分析表 And Range(a & i) 工程名称： Then If Application.WorksheetFunction.CountIf(Range(a1:a65536), Range(a & i) 1 Then Rows(i).Select Selection.Delete End If End IfNextApplication.ScreenUpdating = TrueMsgBox 完成，耗时 & Timer - t & 秒End Sub7. 筛选 by:Qee用2007322请教如何排序筛选.xlsFunction rr(ByVal s As String) As String Dim i%, arr(1 To 15) As Boolean, ar ar = Split(s, ) For i = 0 To UBound(ar) arr(Val(ar(i) = True Next i For i = 1 To 15 If Not arr(i) Then rr = rr & Format(i, 00) & Next i rr = Trim(rr)End Function8. VBA编程问答程序集 by:fanjy/dispbbs.asp?boardid=2&replyid=698285&id=180664&page=1&skin=0&Star=1/dispbbs.asp?boardID=2&ID=190388&page=1&px=0原创VBA语句集100句(第2辑)fanjy 发表于 2006-6-24 14:56:22 VBA语句集(第2辑)*定制模块行为(101) Err.Clear 清除程序运行过程中所有的错误*工作簿(102) ThisWorkbook.BuiltinDocumentProperties(“Last Save Time”)或Application.Caller.Parent.Parent.BuiltinDocumentProperties(“Last Save Time”) 返回上次保存工作簿的日期和时间(103) ThisWorkbook.BuiltinDocumentProperties(Last Print Date)或Application.Caller.Parent.Parent.BuiltinDocumentProperties(“Last Print Date”) 返回上次打印或预览工作簿的日期和时间(104) Workbooks.Close 关闭所有打开的工作簿(105) ActiveWorkbook.LinkSources(xlExcelLinks)(1) 返回当前工作簿中的第一条链接(106) ActiveWorkbook.CodeNameThisWorkbook.CodeName 返回工作簿代码的名称(107) ActiveWorkbook.FileFormat ThisWorkbook.FileFormat 返回当前工作簿文件格式代码(108) ThisWorkbook.PathActiveWorkbook.Path 返回当前工作簿的路径(注:若工作簿未保存,则为空)(109) ThisWorkbook.ReadOnly ActiveWorkbook.ReadOnly 返回当前工作簿的读/写值(为False)(110) ThisWorkbook.SavedActiveWorkbook.Saved 返回工作簿的存储值(若已保存则为False)(111) Application.Visible = False 隐藏工作簿 Application.Visible = True 显示工作簿 注:可与用户窗体配合使用,即在打开工作簿时将工作簿隐藏,只显示用户窗体.可设置控制按钮控制工作簿可见*工作表(112) ActiveSheet.Columns(B).Insert 在A列右侧插入列，即插入B列ActiveSheet.Columns(E).Cut ActiveSheet.Columns(B).Insert 以上两句将E列数据移至B列，原B列及以后的数据相应后移ActiveSheet.Columns(B).Cut ActiveSheet.Columns(E).Insert 以上两句将B列数据移至D列，原C列和D列数据相应左移一列(113) ActiveSheet.Calculate 计算当前工作表(114) ThisWorkbook.Worksheets(“sheet1”).Visible=xlSheetHidden 正常隐藏工作表，同在Excel菜单中选择“格式工作表隐藏”操作一样ThisWorkbook.Worksheets(“sheet1”).Visible=xlSheetVeryHidden 隐藏工作表，不能通过在Excel菜单中选择“格式工作表取消隐藏”来重新显示工作表ThisWorkbook.Worksheets(“sheet1”).Visible=xlSheetVisible 显示被隐藏的工作表(115) ThisWorkbook.Sheets(1).ProtectContents 检查工作表是否受到保护(116) ThisWorkbook.Worksheets.