VBA程序集.docVIP

VBA程序集 (第1辑) 程序1(对工作簿的操作)[程序功能] 关闭工作簿[情形一] 关闭并保存所有工作簿Option ExplicitSub CloseAllWorkbooks() Dim Book As Workbook For Each Book In WorkbooksIf Book.NameThisWorkbook.Name Then Book.Close savechanges:=TrueEnd If Next Book ThisWorkbook.Close savechanges:=TrueEnd Sub [情形二] 关闭工作簿并将它彻底删除Option ExplicitSub KillMe()With ThisWorkbook .Saved = True .ChangeFileAccess Mode:=xlReadOnly Kill .FullName .Close FalseEnd WithEnd Sub[程序说明]1、使用本程序时应注意，运行它将彻底删除工作簿。2、本程序可用于：(1)工作簿到某时间需删除时；(2)没有工作簿权限，输入错误的密码时。 ***************************************************************** 程序2(对单元格的操作)[程序功能] 计算工作表中已使用单元格行列数[方法一]Sub 计算行数() 计算工作表中已使用单元格的行数Dim rng As RangeDim r as longSet rng = ActiveSheet.UsedRanger= rng.Rows.CountEnd Sub[方法二]Sub 计算行数() 计算工作表中已使用单元格的行数Dim r as longr = Sheets(1).[a65536].End(xlUp).RowEnd Sub[程序说明]但此方法只能以一列为基础取行数，当另一列行数比该列行数多时，不能反映已使用的行数。比较后认为，采用方法一较通用。类似地，取列数方法相同。 ****************************************************** 程序3(对列表区域数据的操作—排序)[程序功能] 对一列中所选择的数据进行排序，选择列表中选区的任一单元格后，消息对话框显示出该单元格数值在选区中的排序位置。[程序]Option Explicit ‘进行变量声明Dim MyCell As RangeDim r As IntegerDim MyRange As RangeDim Ans Sub rankalist() Dim m As Integer Set MyRange = Selection  On Error Resume Next m = Selection.Count MsgBox Selection has m cells., vbInformation, Selection Count Call rankprocess ‘调用子过程  While Ans = vbYes Call rankprocess Wend  While Ans = vbNo Exit Sub WendEnd Sub Sub rankprocess() Set MyCell = Application.InputBox(prompt:=Please select a cell:, Title:=Cell, Type:=8) ‘用输入框返回一个单元格对象给MyCell对象变量  If Union(MyCell, MyRange).Address = MyRange.Address Then ‘判断单元格是否在选区内 r = 1 + MyRange.Cells.Count - Application.WorksheetFunction.rank(MyCell.Value, MyRange, 0) ‘使用Excel的rank函数进行排序 Ans = MsgBox( the present cell is ranked r in the list vbNewLine Continue?, vbYesNo) ‘显示排序结果并询问是否继续查看其它单元格排序，还是退出 Else MsgBox Please select a cell in selection. End IfEnd Sub ****