VB学习的东东

Long_III兄在ExcelHome开了个帖子--部分程序代码注释，供入门新手学习 反应热烈。本着见贤思齐的心情，在此也开此一帖子，热心的网友请将您认为对新手有帮助的程序做个详细的注释，帮助大家学习。 请大家对此帖子勿灌水，将您的鼓励使用评分表达或将赞美直接发短消息给作者。 坏坏aurora开个头 Sub test() Dim Srng As Range Dim pt As Range With ActiveSheet         ‘取得资料范围         ‘建立表格时最好在四周都留一个空格.这样就不必这么麻烦了         ‘只要用currentregion属性即可     Set Srng = Application.Intersect(.Range("b3").CurrentRegion, .Range("b3:iv65536"))         ‘自动筛选第一个字段不为空者         ‘请注意”<>”是不为空，”=”是空白，” “是ALL喔     Srng.AutoFilter Field:=1, Criteria1:="<>" End With ‘将指标设为B列最底下第一个空白位置 Set pt = Sheet4.Range("b65536").End(xlUp).Offset(1, 0) ‘将筛选后的数据复制到上面只到的位置 ‘没想到吧！筛选后复制不会复制到隐藏的纪录 Srng.Copy pt ‘取消自动筛选 Srng.AutoFilter ‘将标题行删除 pt.EntireRow.Delete Set Srng = Sheet4.Range("b4").CurrentRegion With Sheet3         ‘进阶筛选若将数据转写到新工作表则要从目标工作表开始         ‘所以activate temp工作表     .Activate         ‘先清除资料     .Cells.Clear         ‘不重复筛选转写     Srng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("A1"),’ Unique:=True         ‘入库单原资料清除     Srng.Clear         ‘将筛选数据复制回入库单工作表…..成功!!     .Range("a1").CurrentRegion.Copy Srng.Cells(1) End With End Sub Function Hpizhu(rng As Range) As Boolean '自定义函数，判断一个单元格是否含有批注     Dim s$         On Error GoTo line1 '产生错误的时候跳转到line1行     s = rng.Comment.Text '等于批注的，如果有就不会出错哦，如果没有就会出错     Hpizhu = True     Exit Function '必须要，如果不退出，它会继续执行line1哦 line1:     Hpizhu = False End Function Sub hjs() '随便找两个试试哦     MsgBox Hpizhu(Range("a1"))     MsgBox Hpizhu(Range("a2")) End Sub 1　取得窗体的控件名称 Sub 显示控件的名称()     MsgBox “依序显示各控件的名称”     suu = ActiveSheet.Shapes.Count     For i = 1 To suu         henji = MsgBox (“第 ” & i & “ 个控件名称为：” & ActiveSheet.Shapes(i).Name & “，继续吗？”, vbYesNo)         If henji = vbNo Then Exit Sub     Next i End Sub 2　设定窗体控件的值 Sub 设定控件的值()     MsgBox “点选选项按钮2、取消勾选复选框4”     ActiveSheet.[option button 2].Value = True     ActiveSheet.[check box 4].Value = False End Sub Sub 显示或隐藏Office小帮手()     MsgBox "切换Office小帮手显示/隐藏的状态"     Assistant.Visible = Not (Assistant.Visible) End Sub Sub 移动Office小帮手()     x = 200     y = 250     MsgBox "将Office小帮手移到屏幕(" & x & "," & y & ")的位置"     Assistant.Move x, y End Sub Sub 设定动画效果()     MsgBox "依序显示Office小帮手的动画效果类型"     anime = Application.Assistant.Animation     For i = 100 To 116         Application.Assistant.Animation = i         MsgBox "Office小帮手目前的动画效果常数值：" & i     Next i     MsgBox "回复原来的动画效果"     Application.Assistant.Animation = anime End Sub Sub 汽球中的提示讯息()     MsgBox "建立汽球，并在汽球中显示提示讯息"    With Assistant.NewBalloon         .Icon = msoIconTip         .Heading = "小计的使用"         .Labels(1).Text = "首先，请点选「数据」"         .Labels(2).Text = "其次，请点选「小计」"         .Button = msoButtonSetOK         .Show     End With     Application.Assistant.Visible = False End Sub Sub 汽球与标签的应用()     MsgBox "为Office小帮手建立内含卷标选项的汽球"     With Application.Assistant.NewBalloon         .Heading = "◆数据排序◆"         .Text = "请点选下列的项目："         .Labels(1).Text = "依据姓名递增排序"         .Labels(2).Text = "依据编号排序"         .Labels(3).Text = "取消"         .Button = msoButtonSetNone         sentaku = .Show     End With     Select Case sentaku     Case 1         MsgBox "依据姓名递增排序"         hanni = "A2:C12"         kii = "B2"         ActiveSheet.Range(hanni).Select         retu = Range(kii).Value         Selection.Sort key1:=Range(kii), header:=xlYes, Order1:=xlAscending     Case 2         MsgBox "依据编号排序"         hanni = "A2:C12"         kii = "A2"         ActiveSheet.Range(hanni).Select         retu = Range(kii).Value         Selection.Sort key1:=Range(kii), header:=xlYes, Order1:=xlAscending     Case 3         MsgBox "取消"     End Select End Sub Sub 汽球与复选框的应用()     MsgBox "为Office小帮手建立内含复选框的汽球"     With Assistant.NewBalloon         .Heading = "变更A2到C2储存格范围的格式"         .Text = "勾选欲执行的项目后，请按OK "         .CheckBoxes(1).Text = "变更为粗体字"         .CheckBoxes(2).Text = "变更为斜体字"         .Button = msoButtonSetOK         .Show         If .CheckBoxes(1).Checked = True Then             Range("A2:C2").Font.Bold = True         Else             Range("A2:C2").Font.Bold = False         End If         If .CheckBoxes(2).Checked = True Then             Range("A2:C2").Font.Italic = True         Else             Range("A2:C2").Font.Italic = False         End If End With End Sub 这个程序列出系统所有字型名称于工作表之第一列 Sub GetFontList() '正确的宣告帮助快速写出正确代码 '我们要找的是一个CommandBarComboBox, 所以... Dim myControl As CommandBarComboBox Dim i As Integer '指定对象要用Set '现在要在格式工具列中寻找字型那个命令列组合框 '那个组合框的ID是1728, 请参考"Excel菜单选项及内置图标总阅览"     Set myControl = Application.CommandBars("Formatting").FindControl(ID:=1728) '使用With...End With结构可加快速度及简化代码     With myControl '将组合框内的项目列出在第一列         For i = 1 To .ListCount             Cells(i, 1) = .List(i)         Next     End With End Sub Sub 开启最近使用过的档案()     MsgBox "显示最近使用过的第二个文件名称，并开启它"     MsgBox Application.RecentFiles(2).Name     Application.RecentFiles(2).Open End Sub Sub 内存容量()     MsgBox "Excel可使用的内存大小为：" & Application.MemoryTotal     MsgBox "Excel已使用的内存为：" & Application.MemoryUsed     MsgBox "Excel剩余的内存大小为：" & Application.MemoryFree End Sub Sub 全屏幕模式()     Dim gamen As Boolean     MsgBox "将Excel的显示模式设为全屏幕"     gamen = Application.DisplayFullScreen     Application.DisplayFullScreen = True     MsgBox "回复原来的状态"     Application.DisplayFullScreen = gamen End Su 摘自主题花园精华(一) http://www.officefans.net/cdb/viewthread.php?tid=767 此程序列出VBE已经加载的Addins Sub ListRunningAddins() 'Define as a VBE Addin, not an Excel one ‘宣告一个VBE的Addin对象，不是Excel上的喔 ‘如此宣告需设定引用Microsoft Visual Basic for Applications Extensibility x.x Dim oAddin As VBIDE.AddIn ‘如此宣告则不必，但其属性及方法等则不会自动显示 ‘若你对此对象熟悉则可以采用，免去设定引用项目的麻烦 'Dim oAddin As Object 'Loop through the VBE's addins ‘循环遍历所有VBE中之Addins For Each oAddin In Application.VBE.AddIns 'Is it active (i.e. connected)? ‘有否载入? If oAddin.Connect Then 'Yes, so show it's ID and description ‘有的话，在实时运算窗口中显示其名称和叙述 Debug.Print oAddin.progID, oAddin.Description End If Next End Sub 摘自主题花园精华(一) http://www.officefans.net/cdb/viewthread.php?tid=767 Option Explicit '这是一个病毒, 这个病毒非病毒 '只因为防毒软件认为此程序可疑, 因此可能遭到防毒软件逮捕, 关进隔离所 '这个程序 '1. 开启一个新工作簿 '2. 复制Userform1到新工作簿 '3. 在新工作簿生成一个一般模块 '4. 在该模块自动产生代码 '5. 执行该代码显示其Userform1 '请设定引用项目Microsoft Visual Basic for Application Extensibility x.x '请开启[信任存取Visul Basic专案] '平常为防止宏病毒, [信任存取Visul Basic项目]最好关闭 Sub CopyAndShowUserForm() '适当宣告对象 Dim oNewBk As Workbook, oVBC As VBIDE.VBComponent 'Create a new workbook '建立新工作簿 Set oNewBk = Workbooks.Add 'Export a UserForm from this workbook to disk '汇出本工作簿之Userform到硬盘 ThisWorkbook.VBProject.VBComponents("UserForm1").Export "c:\temp.frm" 'Import the UserForm into the new workbook '自硬盘汇入Userform至新工作簿 Set oVBC = oNewBk.VBProject.VBComponents.Import("c:\temp.frm") 'Rename the UserForm '重新命名该Userfrom为MyForm oVBC.Name = "MyForm" 'Add a standard module to the new workbook '在新工作簿新增一个一般模块 Set oVBC = oNewBk.VBProject.VBComponents.Add(vbext_ct_StdModule) 'Add some code to the standard module, to show the form '在该模块加上显示Myform的代码 oVBC.CodeModule.AddFromString _ "Sub ShowMyForm()" & vbCrLf & _ " MyForm.Show" & vbCrLf & _ "End Sub" & vbCrLf 'Close the code pane the Excel opened when you added code to the module '增加了代码以后关闭该模块窗口 oVBC.CodeModule.CodePane.Window.Close 'Delete the exported file '删除汇出的档案 Kill "c:\temp.frm" 'Run the new routine to show the imported UserForm '执行刚加上的程序来显示Myform Application.Run oNewBk.Name & "!ShowMyForm" End Sub 动态新增与解除引用项目 1. 动态新增引用项目 Sub DynAddRef(strFname As String) ‘strName: 引用项目文件名称 ‘使用FileSearch对象寻找该档案的完整路径 With Application.FileSearch ‘MS Windows大概都在下面的路径，可以自行增加     .LookIn = "C:\windows\system32;c:\winnt\system32"     .SearchSubFolders = True     .Filename = strFname     .MatchTextExactly = True     If .Execute <> 0 Then ‘若找到加入引用         On Error Resume Next         ThisWorkbook.VBProject.References.AddFromFile .FoundFiles(1)     Else ‘没有找到停止程序执行         MsgBox "Not found file: " & strFname         End     End If End With End Sub 2. 解除引用项目 Sub DynRemoveRef(strFname As String) ‘strFname:要解除的项目文件名 ‘若引用「Microsoft Visual Basic for Application Extensibility 5.3」 ’则可宣告为Dim theRef as VBIDE.Reference Dim theRef ‘一个暂存Variant变数 Dim tmpArr ‘在项目中引用项目集合中搜寻 With ThisWorkbook.VBProject.References     For Each theRef In .Parent.References ‘拆分路径         tmpArr = Split(theRef.fullpath, "\") ‘tmpArr最后的元素即为文件名称         tmpArr = StrConv(tmpArr(UBound(tmpArr)), vbUpperCase)         If tmpArr = StrConv(strFname, vbUpperCase) Then ‘若为要解除的档案则解除之             .Remove theRef         End If     Next End With End Sub ‘以「Windows Script Host Object Model」(wshom)为例测试引用 Sub testAdd() DynAddRef "wshom.ocx" End Sub ‘以「Windows Script Host Object Model」(wshom)为例测试解除 Sub testRemove() DynRemoveRef "wshom.ocx" End Sub 關於窗口 1　建立窗口的复本 Sub 建立窗口的副本()     MsgBox “以使用中窗口为来源建立一个新的窗口副本”     ActiveWindow.NewWindow End Sub 2　选取窗口 Sub 选取窗口()     MsgBox “依序切换已开启的窗口”     wsuu = Windows.Count     For i = 1 To wsuu         Windows(i).Activate         henji = MsgBox(“第 ” & i & “个窗口，还要继续吗？”, vbYesNo)         If henji = vbNo Then Exit Sub     Next i End Sub 3　关闭窗口 Sub 关闭窗口()     MsgBox “关闭使用中的窗口”     ActiveWindow.Close End Sub 4　显示窗口的标题 Sub 显示窗口的标题()     MsgBox “显示使用中窗口的标题”     MsgBox ActiveWindow.Caption End Sub 5　取得窗口的数量 Sub 取得窗口的数量()     MsgBox “显示目前已开启的窗口数量”     MsgBox Windows.Count End Sub 6　分割窗口与解除分割窗口 Sub 分割窗口()     MsgBox “以使用中储存格为基准点来分割窗口”     gyou = ActiveCell.Row     retu = ActiveCell.Column     With ActiveWindow         .SplitColumn = retu         .SplitRow = gyou     End With     MsgBox “回复原来的状态”     ActiveWindow.Split = False End Sub 7　冻结窗格 Sub 冻解窗格()     MsgBox “以使用中的储存格为基准将窗格冻结”     ActiveWindow.FreezePanes = True End Sub Sub 取消冻结窗格()     MsgBox “取消冻结的窗格”     ActiveWindow.FreezePanes = False End Sub 8　移动窗口的位置 Sub 设定窗口的位置()     MsgBox “将使用中窗口向下移动60点、向右移动90点”     jyoutan = ActiveWindow.Top     satan = ActiveWindow.Left     ActiveWindow.Top = jyoutan + 60     ActiveWindow.Left = satan + 90     MsgBox “回复原来的状态”     ActiveWindow.Top = jyoutan     ActiveWindow.Left = satan End Sub 9　变更窗口的高度及宽度 Sub 变更窗口的高度及宽度()     MsgBox “将使用中窗口的高度及宽度各缩减一半”     takasa = ActiveWindow.Height     haba = ActiveWindow.Width     ActiveWindow.Height = takasa / 2     ActiveWindow.Width = haba / 2     MsgBox “回复原来的状态”     ActiveWindow.Height = takasa     ActiveWindow.Width = haba End Sub 10　锁定窗口的尺寸 Sub 窗口尺寸的变更()     MsgBox “锁定/解除窗口尺寸变更的功能”     ActiveWindow.EnableResize = Not (ActiveWindow.EnableResize) End Sub 11　变更窗口网格线的颜色 Sub 设定窗口的网格线颜色()     MsgBox “将窗口的网格线颜色变更为红色”     iro = ActiveWindow.GridlineColor     ActiveWindow.GridlineColor = RGB(255,0,0)    MsgBox “回复原来的状态”     ActiveWindow.GridlineColor = iro End Sub 12　重排窗口 Sub 重排窗口()     MsgBox "将目前所有开启的窗口以阶梯式并排的方式来排列"    Windows.Arrange arrangestyle:=xlArrangeStyleCascade End Sub Sub 重排窗口()     MsgBox "将目前所有开启的窗口以砖块式并排的方式来排列"     MsgBox "目前开启的窗口数量：" & Windows.Count     Application.Windows.Arrange arrangestyle:=xlArrangeStyleTiled End Sub 13　窗口的最大化及最小化 Sub 设定窗口的状态()     MsgBox “将使用中窗口变为最小化”     Windows(1).WindowState = xlMinimized     MsgBox “将使用中窗口变为最大化”     Windows(1).WindowState = xlMaximized End Sub 14　隐藏最大化及最小化的按钮 Sub 隐藏最大化及最小化的按钮()     MsgBox “隐藏窗口中最大化及最小化的按钮”     ActiveWindow.EnableResize = Not (ActiveWindow.EnableResize)     MsgBox “回复原来的状态”     ActiveWindow.EnableResize = True End Sub 15　将最上层的窗口移到最下层 Sub 将窗口移到最下层()     MsgBox “将使用中的窗口移到最下层”     ActiveWindow.ActivateNext End Sub 16　将最下层的窗口移到最上层 Sub 将窗口移到最上层()     MsgBox “将最下层的窗口移到最上层”     ActiveWindow.ActivatePrevious End Sub 17　显示储存格内的表达式 Sub 显示表达式()     MsgBox “在使用中窗口内，让有表达式的储存格显示表达式”     ActiveWindow.DisplayFormulas = True     MsgBox “回复原来的状态”     ActiveWindow.DisplayFormulas = False End Sub 18　显示或隐藏零值 Sub 显示或隐藏零值()     MsgBox “显示/隐藏使用中窗口内的零值”     ActiveWindow.DisplayZeros = Not (ActiveWindow.DisplayZeros) End Sub 19　显示及隐藏网格线 Sub 显示或隐藏网格线()     MsgBox “显示/隐藏使用中窗口的网格线”     ActiveWindow.DisplayGridlines = Not (ActiveWindow.DisplayGridlines) End Sub 20　以列或行为单位卷动窗口内容 Sub 列的卷动()     MsgBox “将窗口画面向下卷动五列”     gyou = 5     ActiveWindow.SmallScroll Down:=gyou End Sub Sub 行的卷动()     MsgBox “将窗口画面向右卷动两行”     retu = 2     ActiveWindow.SmallScroll ToRight:=retu End Sub 21　以页为单位卷动窗口内容 Sub 页的卷动()     MsgBox “将窗口画面向下卷动一页”     pge = 1     ActiveWindow.LargeScroll Down:=pge End Sub 22　显示、隐藏水平滚动条及垂直滚动条 Sub 隐藏窗口的滚动条()     MsgBox “隐藏/显示使用中窗口的滚动条”     ActiveWindow.DisplayHorizontalScrollBar = Not (ActiveWindow.DisplayHorizontalScrollBar)     ActiveWindow.DisplayVerticalScrollBar = Not (ActiveWindow.DisplayVerticalScrollBar) End Sub Sub 隐藏活页簿的滚动条()     MsgBox “隐藏/显示活页簿的水平及垂直滚动条”     Application.DisplayScrollBars = Not (Application.DisplayScrollBars) End Sub 23　以指定的储存格卷动到窗口左上角 Sub 以窗口左上角为基准的窗口画面卷动()     MsgBox “将储存格C6卷动到窗口的左上角”     ActiveWindow.ScrollRow = 6     ActiveWindow.ScrollColumn = 3 End Sub 以部分字段元为键来删除重复 要判断这样的不重复，就是将数据范围设定为包含不重复的字段，以进阶筛选执行不选重复的纪录。再利用另一工作表为暂存区，将筛选后的数据复制过去，清除原数据，再将暂存工作表的数据复制回来。 代码如下 Sub DelDupRecP()     Dim Cols As Range     Dim shtTmp As Worksheet         '备妥暂存工作表     Set shtTmp = Sheet2     shtTmp.Cells.Clear         '设定B与C栏不重复筛选     Set Cols = Sheet1.Range("b1:c7")     With Cols         .AdvancedFilter Action:=xlFilterInPlace, Unique:=True         '复制到暂存工作表         .EntireRow.Copy shtTmp.Range("a1")         '全部显示         .Worksheet.ShowAllData         '清除原有数据         .Worksheet.Cells.Clear         '自暂存工作表复制回来         shtTmp.UsedRange.Copy .Worksheet.Range("a1")     End With End Sub Private Sub CommandButton1_Click() Dim shp As Shape ‘当你刚加入图片，则该图片的index即为shapes.count Set shp = Me.Shapes(Me.Shapes.Count) ‘判断是否为图片 If shp.Type = msoPicture Then ‘选定它并推至最下层     shp.Select     Selection.ShapeRange.ZOrder msoSendToBack End If End Sub 工作表中插入的对象都是Shape，要判断是何种型态的Shape，可用Type属性 Type属性传回图案类型。只读的 MsoShapeType 数据型态。 MsoShapeType 可以是这些 MsoShapeType 常数之一。 msoAutoShape msoCallout msoCanvas msoChart msoComment msoDiagram msoEmbeddedOLEObject msoFormControl msoFreeform msoGroup msoLine msoLinkedOLEObject msoLinkedPicture msoMedia  无法与这个属性一起使用。此常数需与其它 Microsoft Office 应用程序中的图案一起使用。 msoOLEControlObject msoPicture msoPlaceholder  无法与这个属性一起使用。此常数需与其它 Microsoft Office 应用程序中的图案一起使用。 msoScriptAnchor msoShapeTypeMixed msoTable msoTextBox msoTextEffect 用法： expression.Type expression  必选的。一个传回上述物件的表达式 数组方法与非数组方法，简单的一个例子。如果大量操作单元格，用这种方法可以提速。下面例子，数组方法约0.04秒，而非数组方法却至少要4秒，大家可以测试 Const imax As Long = 10000 '定义一个常量，为整型等于10000 Sub hjs() '第一种,把一个数组的值转换为单元格的值     Dim time()     Dim i As Long, aa As Double         aa = Timer     Application.ScreenUpdating = False '关闭屏幕更新，防止闪屏及加快代码运行速度     ReDim time(imax) '重新定义这个数组     For i = 0 To imax '给数组赋值         time(i) = i     Next     [a1].Resize(imax + 1, 1) = Application.WorksheetFunction.Transpose(time) '一次性给单元格赋值     Application.ScreenUpdating = True     MsgBox Format(Timer - aa, "0.000") '记录程序运行的时间 End Sub Sub hjs2() '第二种     Dim time()     Dim i As Long, aa As Double         aa = Timer     Application.ScreenUpdating = False     ReDim time(imax, 0) '另外一种定义一个2维数组，可以直接赋值给单元格     For i = 0 To imax         time(i, 0) = i '给数组赋值     Next     [b1].Resize(imax + 1, 1) = time '两种直接赋值给单元格的方法，自己试试了     Application.ScreenUpdating = True     MsgBox Format(Timer - aa, "0.000") End Sub Sub hjs3() '非数组方法,也是最常用的方法，可以用数组进行提速     Dim i As Long, aa As Double         aa = Timer     Application.ScreenUpdating = False '关闭屏幕更新，防止闪屏及加快代码运行速度     For i = 0 To imax         Cells(i + 1, 3) = i '直接进行单元格的操作     Next     Application.ScreenUpdating = True     MsgBox Format(Timer - aa, "0.000") '记录本程序运行的时间 End Sub 判断一个单元格是否含有引用的自定义函数，不知这么简单的代码会不会影响帖子的精华程度？ Sub hjs()     Dim rng As Range     For Each rng In Range("b5:d7")    '在一个范围里循环，判断里面每个是否含有引用         MsgBox rng.Address & "-" & Yyong(rng)     Next End Sub Function Yyong(rng As Range) As Boolean    '判断一个单元格是否含有引用单元格,如＝a1+1，就算含有引用     Dim t%, t1%     Yyong = False     With rng         t = .Parent.Shapes.Count    '计算rng的表里的所有图形的总个数         rng.ShowPrecedents    '显示引用的箭头，如果有引用，则此时的工作表所有的图形个数就大于之前的值t         t1 = .Parent.Shapes.Count    '         If t1 <> t Then Yyong = True: .ShowPrecedents True    '最好移除显示引用的箭头     End With End Function 帮老板做事时偷懒整出来的东西,大家分享一下! 功能: 选定文件夹,将里面的JPG文件(当然你可以改变扩展名实现对其他文件的支持)全部按文件夹名称+001,002,003...这样的序号进行重命名,可以撤销及重做一次. : 没有多大的意义.(因老板不喜欢数码相机自动编号的英文名称,几千张照片要我按文件夹及序号重新命名才偷懒写了这些代码) 主要是示范以下方法: 1  Application.FileDialog(msoFileDialogFolderPicker) 2  Application.FileSearch 3  Application.OnRepeat 重做只会出现在编辑菜单而不是撤销箭头的旁边那个??Microsoft真是奇怪 4  Application.OnUndo Option Explicit Public oldNames() As String, newNames() As String Sub ReNameFiles() Dim i%, iCount% Dim Oldname$, Newname$, strExName$ Dim fd As FileDialog Dim VarPath As Variant '用FileDialog对象来取得要重命名文件的文件夹 Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd         '.AllowMultiSelect = True         '是否允许多重选择         .InitialFileName = "D:\"          '指定初始位置         If .Show = -1 Then                '如果选择了确定按钮             VarPath = .SelectedItems(1)   '记录下选取文件夹的路径         Else             '如果选择了取消 (.Show = 0)             MsgBox "您没有选择任何文件夹,系统将退出!", 0 + 48, "系统": Set fd = Nothing: Exit Sub '按取消之后退出程序         End If End With strExName = ".jpg"                  '指定要重命名文件的扩展名 With Application.FileSearch         '用FileSearch取得文件夹内文件     .NewSearch                      '开始一个新搜索     .LookIn = VarPath               '指定搜索范围为刚才选择的文件夹     .SearchSubFolders = False       '不搜索子文件夹     .Filename = "*" & strExName     '指定*.jpg     .MatchTextExactly = True        '指定搜索名称为完全匹配     .FileType = msoFileTypeAllFiles '文件类型为所有文件(实际类型已通过*.jpg指定)           If .Execute() > 0 Then          '如果搜索到匹配的文件         iCount = .FoundFiles.Count         MsgBox "There were " & iCount & " file(s) found.", 0 + 64, "系统"         ReDim oldNames(iCount): ReDim newNames(iCount)  '重定义数组大小为找到文件个数         For i = 1 To iCount              '新的名称为 "文件夹名称" + 序号(按"01"或"001"或"0001"的形式) + 扩展名              Newname = Dir(VarPath, vbDirectory) & _                          IIf(iCount < 100, Format(i, "00"), IIf(iCount < 1000, Format(i, "000"), Format(i, "0000"))) & _                            strExName              Debug.Print CStr(.FoundFiles(i)) & " --> " & Newname              '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''              newNames(i) = CStr(VarPath & "\" & Newname)                  '存储新文件名以备撤销              oldNames(i) = CStr(.FoundFiles(i))                           '存储旧文件名以备撤销              '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''              Name CStr(.FoundFiles(i)) As Newname                         '重命名         Next i     Else         MsgBox "There were no files found."                               '如果没有匹配的文件     End If         Application.OnUndo "撤销重命名", "my_undo"                   '激活撤销     End With End Sub Private Sub my_undo() Dim i% For i = 1 To UBound(newNames)     Name newNames(i) As oldNames(i) Next i Application.OnRepeat "重做重命名", "my_Repeat"               '激活重做 (注: 重做只会出现在编辑菜单而不是撤销箭头的旁边那个??Microsoft真是奇怪) End Sub Private Sub my_Repeat() Dim i% For i = 1 To UBound(newNames)     Name oldNames(i) As newNames(i) Next i Application.OnUndo "撤销重命名", "my_undo"                   '激活撤销 End Sub 字典的应用。在200个“所在单位”里，随机选取20个单位，并统计随机单位出现的次数。动态数组、字典的应用等都是很重要的提速技巧，值得关注！代码为： Private Sub CommandButton1_Click()     Dim i%, a%, m%, arr()    '定义变量，％为整型变量     Dim s%, Yarr     Dim ds    '定义ds为字典     Set ds = CreateObject("scripting.dictionary")    '设置一个新字典     Application.ScreenUpdating = False    '关闭屏幕更新     t = 20    '随机取的总数     Yarr = Range("a2:a201")    '用Yarr数组记录下200个单位     Randomize    '初始化随机数     On Error Resume Next    '在字典增加重复数值的时候会产生错误，用这句忽略错误     For a = 1 To t    '只表示循环t次,a无实在意义         i = Int(Rnd * 200) + 1    '从1到200的随机数         ds.Add i, m + 1    '增加到字典里面去，记录i的值，及数组对应的位置         If Err.Number = 0 Then    '假如增加的时候没有重复的话，则增加一次到数组里去             m = m + 1             ReDim Preserve arr(1 To 2, 1 To m)    '重新定义一个二维的动态数组             arr(1, m) = Yarr(i, 1)    '给数组赋值             arr(2, m) = 1    '第一次记录次数为1         Else             s = ds(i)    '如果增加的时候有重复的话，用s来取得原先记录进字典里的数组的位置，即早先的m+1             arr(2, s) = arr(2, s) + 1    '多增加1次它的次数         End If         Err.Clear    '清除错误     Next     On Error GoTo 0    '下次出错的时候继续报错