[分享]ExcelVBA程序集汇总(连续更新中......)

fanjy · 发表于 2006-8-9 21:58

<如果大家有好的源程序，欢迎您贴出来供分享，相信大家会感激您的。同时，您也可以对本贴中的程序进行评论和改进，也希望本贴中尽量不要跟一些与本主题无关的贴子>

VBA程序集
(汇总)

VBA程序集的目的是尽可能汇集一些优秀的源程序代码和常用的示例代码，以方便对VBA的学习和查阅。在对程序源代码的阅读和研究过程中，随着您思考的深入，您将会逐渐熟悉VBA的语法和对象，从而不断提高VBA编程水平和技术。其中的一些代码可直接运用到您的应用程序中，也可以根据您的需要稍作调整或修改后运用到您的应用程序中。一小段代码也能附加额外的功能或增强现有的功能，或许能大大改善您的工作效率。
在各个程序中，对程序功能进行了简要介绍，并对相关程序代码进行说明，以及就个人的理解简要叙述了如何对该程序功能进行扩展和利用。这些程序代码后，大都附有示例工作簿可供下载后调试。

在使用程序前，您必须先创建它。您可以在VBE编辑器中输入或粘贴下面的代码以创建宏程序，然后执行工作表菜单“工具”中的宏程序，或者在工作表中为自定义的菜单或命令按钮附加宏，这样就可以方便使用它们。
1. 打开您想创建宏程序的工作簿或新工作簿。
2. 在工作表中选择菜单“工具——宏——Visual Basic编辑器”(或按Alt+F11组合键)，打开VBE编辑器。
3. 在VBE编辑器中选择菜单“插入——模块”，插入一个模块并打开代码窗口。
4. 在代码窗口中输入或粘贴程序代码。
5. 关闭VBE窗口。
6. 若程序要求运行前需要选择单元格区域或特定单元格，则先按要求选择。
7. 选择工作表菜单“工具——宏——宏”命令，打开“宏”对话框。在“宏”对话框中选择所创建的宏，单击“执行”按钮运行宏程序。
提示 (1) 当然，上面的创建和使用程序的过程不是唯一的，您可以根据习惯来进行，如可以直接在VBE编辑器中运行宏，但需转换至工作表查看结果，或者将宏程序附加到自定义菜单或按钮中，点击它们即运行。
(2) 在阅读或理解这些程序的时候，您应该思考如何扩展这些应用程序来满足您的需要。

下面为以前收集整理的程序以及相应的链接：
VBA程序集(第1辑)
程序1：关闭工作簿(1)关闭并保存工作簿；(2)关闭并彻底删除工作簿
程序2：计算工作表中已使用单元格的行数
程序3：对一列中所选择的数据进行排序并显示选中的单元格中数值的位置
程序4：在指定列中寻找字符串，并删除该字符串所在行
程序5：创建三维饼图
链接：http://club.excelhome.net/viewthread.php?tid=170691&replyID=&skin=0
VBA程序集(第2辑)
程序6：搜索值并输入到指定的工作表中
程序7：根据所搜索的值，在该值前插入行
程序8：复制单元格内容为工作表名的行至相应的工作表中
程序9：通过列表框/组合框，逐层分类
程序10：实现连续打印
链接：http://club.excelhome.net/viewthread.php?tid=172488&replyID=&skin=0
VBA程序集(第3辑)
程序11：将所选列中的数值转换成文本
程序12：根据列条件复制行到新的工作表中
链接：http://club.excelhome.net/viewthread.php?tid=173490&replyID=&skin=0
VBA程序集(第4辑)
程序13：根据列中的单元格值决定对该单元格所在行的操作
程序14：实现文本框输入焦点自动转移
程序15：创建对象集合并使用
程序16：在某列输入数据后，对应列自动添加代码
程序17：打开工作簿后只显示用户窗体
链接：http://club.excelhome.net/viewthread.php?tid=174169&replyID=&skin=0
VBA程序集(第5辑)
程序18：将Excel数据表输出为一个带有逗号和引号分隔符的文本文件
程序19：统计所选区域中包含公式、文本或数字的单元格数
程序20：使用Saved属性判断工作簿是否有改变
程序21：连接相邻两列单元格中的数据
程序22：汇总单元格区域的行单元格值和列单元格值
链接：http://club.excelhome.net/viewthread.php?tid=174960&replyID=&skin=0
VBA程序集(第6辑)
程序23：更改Excel工作表中左上角的图标
程序24：更改Excel工作簿中左上角的图标
程序25：移除Excel工作簿或工作表窗口中左上角的图标以及按钮
程序26：移除Excel工作簿和工作表窗口中左上角的图标以及按钮并定制菜单和工具栏
链接：http://club.excelhome.net/viewthread.php?tid=176055&replyID=&skin=0

下面为以后逐步收集归纳的程序(不断更新中......)：
程序27：限制文本框中输入的内容(在第3楼)
程序28：列出所有的颜色和索引值(在第3楼)
程序29：合并单元格中的内容(在第3楼)
程序30：分离单元格中的内容(在第3楼)
程序31：自动安装加载宏(在第3楼)
程序32：在工作表中添加一个箭头(在第3楼)
程序33：提示用户所要进行的操作(在第3楼)
程序34：根据指定列中的数据隐藏相应的行(在第3楼)

程序35：创建一个固定宽度的文本文件(在第4楼)

程序36：生成并分解数组(在第5楼)

程序37：对给定的每个数据依次列出指定的次数(第6楼)

程序38：将前一个值作为批注显示(第8楼)

程序39：删除对其它工作表或工作簿的链接(第12楼)

程序40：工作表事件与OnTime方法示例(第13楼)

程序41：阻止工作表自动添加超链接(第15楼)

程序42：重新排列数据(第16楼)

程序43：在VBA中应用Match函数(第18楼)

程序44：对工作表进行排序(第21楼)

程序45：从筛选后的数据中创建数组(第22楼)

程序46：工作表列A的值改变时,重新排序(第23楼)

程序47：UCase函数的使用(第24楼)

程序48：阻止另存为命令的使用(第25楼)
程序49：阻止用户打印工作簿(第25楼)
程序50：阻止打印工作簿中的部分工作表(第25楼)
程序51：阻止用户在工作簿中添加新工作表(第25楼)

程序52：一个进度条示例(第27楼)

程序53：将公式结果转换为值(第29楼)

程序54：删除工作表中无内容的标题行所在的列(第36楼)

[此贴子已经被作者于2006-9-18 19:00:39编辑过]

fanjy · 发表于 2006-8-9 21:58

<预占>

fanjy · 发表于 2006-8-9 22:02

程序27(文本框-限制文本框中输入的内容)
本程序提供了限制用户在文本框中所能够输入的内容的示例。在示例中，您只能在文本框中输入数字，在第一个字符的位置输入“-”号，以及输入中文字符。当然，您可以修改Case语句中的第一个Case语句，来设定允许输入的字符类型。
[程序代码]
‘******************************************************
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
    Case Asc("0") To Asc("9")
    Case Asc("-")
        If Instr(1,Me.TextBox1.Text,"-") > 0 Or Me.TextBox1.SelStart > 0 Then
            KeyAscii = 0
        End If
    Case Asc(".")
        If InStr(1, Me.TextBox1.Text, ".") > 0 Then
            KeyAscii = 0
        End If
    Case Else
        KeyAscii = 0
End Select
End Sub
‘******************************************************
[示例文档见 (程序27)文本框输入测试.xls。 uWGAjPdr.rar (7.76 KB, 下载次数: 408)

By fanjy in 2006-8-9

[此贴子已经被作者于2006-8-9 22:05:39编辑过]

fanjy · 发表于 2006-8-10 14:35

程序35：创建一个固定宽度的文本文件
有时，我们可能想从一个Excel工作表中创建一个固定宽度的文本文件，下面的程序将完成这个功能。您需要传递文件名、工作表和一个以0为起始的固定宽度的数组到该程序中。
程序代码：
‘*********************************************************
Sub CreateFixedWidthFile(strFile As String, ws As Worksheet, s() As Integer)
Dim i As Long, j As Long
Dim strLine As String, strCell As String

'获取一个文件号
Dim fNum As Long
fNum = FreeFile

'打开文本文件
Open strFile For Output As fNum
'从第1行到最后1行进行循环
'您可以使用2以忽略标题行
For i = 1 To ws.Range("a65536").End(xlUp).Row
    '开始新行
    strLine = ""
    '在每个字段间循环
    For j = 0 To UBound(s)
      '确保我们仅获取与字段长度一致的字符
      '(如果长于字段长度则输出错误)
      strCell = Left$(ws.Cells(i, j + 1).Value, s(j))
        '添加空格符
      strLine = strLine & strCell & String$(s(j) - Len(strCell), Chr$(32))
    Next j
    '写出行
    Print #fNum, strLine
Next i
'关闭文件
Close #fNum
End Sub
‘*********************************************************
您可以输入下面的代码调用以上程序进行测试：
‘*********************************************************
Sub CreateFile()
Dim sPath As String
sPath = Application.GetSaveAsFilename("", "Text Files,*.txt")
If LCase$(sPath) = "false" Then Exit Sub
    '指定字段宽度
    Dim s(6) As Integer
    s(0) = 21
    s(1) = 9
    s(2) = 15
    s(3) = 11
    s(4) = 12
    s(5) = 10
    s(6) = 186
    '如果使用3列,每列字段宽分别为5,10,15,则使用下面代码
     'dim s(2) as Integer
     's(0)=5
     's(1)=10
     's(2)=15
    '从活动工作表写入数据
CreateFixedWidthFile sPath, ActiveSheet, s
End Sub
‘*********************************************************
示例文档见 (程序35)创建固定宽度的文本文件.xls。 mHzhEMJF.rar (8.72 KB, 下载次数: 295)

fanjy · 发表于 2006-8-10 19:04

程序36：生成并分解数组

下面的程序将生成一个数值为1至100的一维数组，并分解成一个多维数组，填充25列和4行单元格区域。

程序代码如下：

‘*********************************************************

Sub SplitArray()

Dim arrBasis(1 To 100) As Integer

Dim arrSplit(1 To 25, 1 To 4) As Integer

Dim iCounter As Integer, iAct As Integer

For iCounter = 1 To 100

arrBasis(iCounter) = iCounter

Next iCounter

For iCounter = 1 To 25

For iAct = 1 To 4

arrSplit(iCounter, iAct) = arrBasis(iCounter * 4 - (4 - iAct))

Next iAct

Next iCounter

Range("A1:D25").Value = arrSplit

End Sub

‘*********************************************************

示例文档见 (程序36)生成并分解数组.xls。

Ig5bv3oW.rar (7.11 KB, 下载次数: 337)

fanjy · 发表于 2006-8-11 13:05

程序37：对给定的每个数据依次列出指定的次数
本程序将对B1至Y3单元格区域中的每个值在一个单独的列中(本例为AA列)依次输入4次。程序代码如下：
‘*********************************************************
Sub ListMultipleTimes()
Application.ScreenUpdating = False
   Dim iRow As Integer, iCol As Integer
   Dim iCounter As Integer, iAct As Integer
   For iRow = 1 To 3
      For iCol = 2 To 25
         For iAct = 1 To 4
         iCounter = iCounter + 1
         Cells(iCounter, 27).Value = Cells(iRow, iCol).Value
         Next iAct
      Next iCol
   Next iRow
   Application.ScreenUpdating = True
End Sub
‘*********************************************************
示例文档见 (程序37)对给定的数据依次列出指定的次数.xls。

gs3quKq6.rar (7.3 KB, 下载次数: 320)

紫蝶儿菲菲 · 发表于 2006-8-11 13:11

挖哈哈。楼主好厉害啊。谢谢了。

fanjy · 发表于 2006-8-12 00:09

程序38：将前一个值作为批注显示

本示例将会把单元格中的前一个值作为该单元格的批注显示。

如果工作簿共享的话，可能有一些用户会改变工作表中的内容，您可以使用该程序知道在其他用户改变之前的单元格中的值。

工作表Sheet2在本示例中用来临时存放单元格之前的值。

下面的代码放在工作表Sheet1的代码模块中。

‘*********************************************************

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'复制该单元格的上一个值至另一个工作表

Sheet2.Range(Target.Address) = Target

End Sub

‘*********************************************************

Private Sub Worksheet_Change(ByVal Target As Range)

On Error Resume Next

'只是清除内容,而不清除格式

Target.ClearComments

With Target

'当单元格中的值变化时获得前一个值

.AddComment

.Comment.Visible = False

.Comment.Text Text:="Previous value = " & Sheet2.Range(Target.Address)

End With

End Sub

‘*********************************************************

示例文档见 (程序38)将前一个值作为批注显示.xls。

A1KYGp22.rar (7.52 KB, 下载次数: 329)

[此贴子已经被作者于2006-8-12 0:09:41编辑过]

lotustower · 发表于 2006-8-12 00:40

程序28(列出所有的顔色和索引值)

初學者混淆 , 為什麼不用

Sub TestColor()
Workbooks.Add
Dim i As Integer
For i = 1 To 56
Cells(i, 1).Value = i
Cells(i, 1).Interior.ColorIndex = i
Next
End Sub

apple_a1 · 发表于 2006-8-12 21:38

楼主辛苦了！

		自动登录	找回密码
密码			免费注册

[分享]ExcelVBA程序集汇总(连续更新中......)

评分