VBA程序集(第1辑)
******************************************************程序1(对工作簿的操作)[程序功能] 关闭工作簿[情形一] 关闭并保存所有工作簿Option ExplicitSub CloseAllWorkbooks() Dim Book As Workbook For Each Book In WorkbooksIf Book.Name<>ThisWorkbook.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)没有工作簿权限，输入错误的密码时。
文档示例见UploadFiles/2006-6/66311071.rar
*****************************************************************
程序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
文档示例见UploadFiles/2006-6/66329144.rar
*******************************************************
程序4(对列表区域数据的操作—排序)[程序功能] 在指定列中寻找所包含的字符串，并删除包含这些字符串的行。按对话框提示输入。[情形一] 字符串必须是单元格中的全部字符Sub 删除行_依全部字符() Dim MyRange As Range, DelRange As Range, C As Range Dim MatchString As String, SearchColumn As String, ActiveColumn As String Dim FirstAddress As String, NullCheck As String Dim AC ‘取活动列号 AC = Split(ActiveCell.EntireColumn.Address(, False), ":") ActiveColumn = AC(0) SearchColumn = InputBox("输入要查找的列号-按取消按钮退出", "删除行", ActiveColumn) On Error Resume Next Set MyRange = Columns(SearchColumn) On Error GoTo 0 ‘若单元格无效则退出 If MyRange Is Nothing Then Exit Sub MatchString = Application.InputBox("输入要查找的完整的字符串", "删除行", ActiveCell.Value) If MatchString = "" Then NullCheck = InputBox("Do you really want to delete rows with empty cells?" & vbNewLine & vbNewLine & _ "Type Yes to do so, else code will exit", "Caution", "No") If NullCheck <> "Yes" Then Exit Sub End If Application.ScreenUpdating = False Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlWhole) ‘要求整个字符串匹配 If Not C Is Nothing Then Set DelRange = C FirstAddress = C.Address Do Set C = MyRange.FindNext(C) Set DelRange = Union(DelRange, C) Loop While FirstAddress <> C.Address End If ‘如果找到匹配的数据则删除该行 If Not DelRange Is Nothing Then DelRange.EntireRow.Delete Application.ScreenUpdating = TrueEnd Sub
[情形二] 字符串可仅为单元格中的部分字符Sub 删除行_依部分字符() Dim MyRange As Range, DelRange As Range, C As Range Dim MatchString As String, SearchColumn As String, ActiveColumn As String Dim FirstAddress As String, NullCheck As String Dim AC ‘取活动列号 AC = Split(ActiveCell.EntireColumn.Address(, False), ":") ActiveColumn = AC(0) SearchColumn = InputBox("输入要查找的列号-按取消按钮退出", "删除行", ActiveColumn) On Error Resume Next Set MyRange = Columns(SearchColumn) On Error GoTo 0 ‘若单元格无效则退出 If MyRange Is Nothing Then Exit Sub MatchString = Application.InputBox("输入要查找的部分字符串", "删除行", ActiveCell.Value) If MatchString = "" Then NullCheck = InputBox("Do you really want to delete rows with empty cells?" & vbNewLine & vbNewLine & _ "Type Yes to do so, else code will exit", "Caution", "No") If NullCheck <> "Yes" Then Exit Sub End If Application.ScreenUpdating = False Set C = MyRange.Find(What:=MatchString, After:=MyRange.Cells(1), LookIn:=xlValues, Lookat:=xlPart) If Not C Is Nothing Then Set DelRange = C FirstAddress = C.Address Do Set C = MyRange.FindNext(C) Set DelRange = Union(DelRange, C) Loop While FirstAddress <> C.Address End If ‘如果找到匹配的数据则删除该行 If Not DelRange Is Nothing Then DelRange.EntireRow.Delete Application.ScreenUpdating = TrueEnd Sub
[程序说明]1、本程序根据网友程序略作改动。2、运行程序后，可根据对话框提示在工作表中直接选择(InputBox函数的功能)。
文档示例见UploadFiles/2006-6/66356445.rar
************************************************************
程序5(图表操作—三维饼图)[程序功能] 创建三维饼图[程序] 建立工作表数据并转换成三维饼图Sub AddChart() Dim colCharts As Object Const xlDataLabelsShowPercent = 3 ‘定义缺省常量，显示图形上的百分比
‘打开Excel，新建一个工作簿和工作表 Set objExcel = CreateObject("Excel.Application") objExcel.Visible = True Set objWorkbook = objExcel.Workbooks.Add() Set objWorksheet = objWorkbook.Worksheets(1)
‘在工作表中输入数据 objWorksheet.Cells(1, 1) = "Operating System" objWorksheet.Cells(2, 1) = "Windows Server 2003" objWorksheet.Cells(3, 1) = "Windows XP" objWorksheet.Cells(4, 1) = "Windows 2000" objWorksheet.Cells(5, 1) = "Windows NT 4.0" objWorksheet.Cells(6, 1) = "Other"
objWorksheet.Cells(1, 2) = "Number of Computers" objWorksheet.Cells(2, 2) = 145 objWorksheet.Cells(3, 2) = 487 objWorksheet.Cells(4, 2) = 211 objWorksheet.Cells(5, 2) = 41 objWorksheet.Cells(6, 2) = 56
‘运用这些数据添加一个新图表 Set objRange = objWorksheet.UsedRange objRange.Select
Set colCharts = objExcel.Charts colCharts.Add
Set objChart = colCharts(1) objChart.Activate
‘设置图表的参数 objChart.ChartType = 70 objChart.Elevation = 30 objChart.Rotation = 80
objChart.ApplyDataLabels xlDataLabelsShowPercent ‘显示在整体中所占百分比的标签
‘去掉绘图区域或图表区域 objChart.PlotArea.Fill.Visible = False objChart.PlotArea.Border.LineStyle = -4142
‘数据标签的大小、颜色、字体样式以及其它属性 objChart.SeriesCollection(1).DataLabels.Font.Size = 14 objChart.SeriesCollection(1).DataLabels.Font.ColorIndex = 2
objChart.ChartArea.Fill.ForeColor.SchemeColor = 49 objChart.ChartArea.Fill.BackColor.SchemeColor = 23 objChart.ChartArea.Fill.TwoColorGradient 1, 1
objChart.ChartTitle.Font.Size = 24 objChart.ChartTitle.Font.ColorIndex = 2
objChart.Legend.Shadow = True
End Sub[程序说明]1、饼图能很形象地表示各部分的百分比。2、Excel可以创建很多种图表和图形，并且每一种类型都被指定了一个唯一的ChartType编号。3、Elevation 属性设置图形的倾斜度。Rotation 属性让图形左右旋转。4、去掉绘图区域或图表区域(即图表上的小框)，只需引用相应的对象（PlotArea 或 ChartArea）。将 Fill.Visible 属性设置为 False。将 Border.LineStyle 属性设置为 -4142，这一常量表示“完全不要显示边框”。请注意，光设置 Visible 属性将达不到效果：如果您仅设置了 Visible 属性，则图表四周仍会有一个灰色边框。要除去这个灰色边框，还需设置 LineStyle 属性。
程序代码见UploadFiles/2006-6/66299865.rar
如此锐气，二十后生有之，六旬男子则更多见。
