VBA程序集的目的是尽可能汇集一些优秀的源程序代码和常用的示例代码，以方便对VBA的学习和查阅。在对程序源代码的阅读和研究过程中，随着您思考的深入，您将会逐渐熟悉VBA的语法和对象，从而不断提高VBA编程水平和技术。其中的一些代码可直接运用到您的应用程序中，也可以根据您的需要稍作调整或修改后运用到您的应用程序中。一小段代码也能附加额外的功能或增强现有的功能，或许能大大改善您的工作效率。
在各个程序中，对程序功能进行了简要介绍，并对相关程序代码进行说明，以及就个人的理解简要叙述了如何对该程序功能进行扩展和利用。这些程序代码后，大都附有示例工作簿可供下载后调试。
在使用程序前，您必须先创建它。您可以在VBE编辑器中输入或粘贴下面的代码以创建宏程序，然后执行工作表菜单“工具”中的宏程序，或者在工作表中为自定义的菜单或命令按钮附加宏，这样就可以方便使用它们。
1. 打开您想创建宏程序的工作簿或新工作簿。
2. 在工作表中选择菜单“工具——宏——Visual Basic编辑器”(或按Alt+F11组合键)，打开VBE编辑器。
3. 在VBE编辑器中选择菜单“插入——模块”，插入一个模块并打开代码窗口。
4. 在代码窗口中输入或粘贴程序代码。
5. 关闭VBE窗口。
6. 若程序要求运行前需要选择单元格区域或特定单元格，则先按要求选择。
7. 选择工作表菜单“工具——宏——宏”命令，打开“宏”对话框。在“宏”对话框中选择所创建的宏，单击“执行”按钮运行宏程序。
对工作薄操作一例：
[程序功能] 关闭工作簿 [情形一] 关闭并保存所有工作簿
Option Explicit
Sub CloseAllWorkbooks()
Dim Book As Workbook
For Each Book In Workbooks
If Book.Name<>ThisWorkbook.Name Then
Book.Close savechanges:=True
End If
Next Book
ThisWorkbook.Close savechanges:=True
End Sub
[情形二] 关闭工作簿并将它彻底删除
Option Explicit
Sub KillMe()
With ThisWorkbook
.Saved = True
.ChangeFileAccess
Mode:=xlReadOnly
Kill .FullName .Close False
End With
End Sub
[程序说明] 1、使用本程序时应注意，运行它将彻底删除工作簿。 2、本程序可用于：(1)工作簿到某时间需删除时；(2)没有工作簿权限，输入错误的密码时。
对单元格的操作
[程序功能] 计算工作表中已使用单元格行列数
[方法一] Sub 计算行数() '计算工作表中已使用单元格的行数
Dim rng As Range
Dim r as long
Set rng = ActiveSheet.UsedRange
r= rng.Rows.Count
End Sub
[方法二] Sub 计算行数() '计算工作表中已使用单元格的行数
Dim r as long
r = Sheets(1).[a65536].End(xlUp).Row
End Sub
[程序说明]但此方法只能以一列为基础取行数，当另一列行数比该列行数多时，不能反映已使用的行数。比较后认为，采用方法一较通用。类似地，取列数方法相同。
对列表区域数据的操作—排序
对一列中所选择的数据进行排序，选择列表中选区的任一单元格后，消息对话框显示出该单元格数值在选区中的排序位置。
[程序]
Option Explicit ‘进行变量声明
Dim MyCell As Range
Dim r As Integer
Dim MyRange As Range
Dim 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
Wend
End 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 If
End 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:=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 = True
End 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 = True
End Sub
图表操作—三维饼图
[程序功能] 创建三维饼图 [程序] 建立工作表数据并转换成三维饼图
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 属性
扫一扫
808
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
