下面为第9辑VBA程序集的内容,包含程序说明、代码和示例文档。
程序46:阻止另存为命令的使用
程序47:阻止用户打印工作簿
程序48:阻止打印工作簿中的部分工作表
程序49:阻止用户在工作簿中添加新工作表
程序50:工作表列A的值改变时,重新排序
程序51:UCase函数的使用
程序52:自动标记指定单元格所在行的颜色
程序53:一个进度条示例
程序54:将公式结果转换为值
[提示]如果您暂时不理解程序,您可以在工作簿中试运行,并改变工作簿中的内容后再运行,以查看运行后的结果,以此来促进程序的理解。
----------------------------------------------------------------------
程序46:阻止另存为命令的使用
本示例将阻止在工作簿中选择菜单“文件——另存为”命令的使用。当您选择“另存为”命令后,将会弹出一个消息框,告诉您不能使用另存为命令更改工作簿的名称。但您可以对该工作簿进行重命名。
下面的代码放置在ThisWorkbook代码模块中:
‘*****************************************************
Private Sub workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim lReply As Long
If SaveAsUI = True Then
lReply = MsgBox("对不起,您不能用其它名称保存本工作簿. ", vbQuestion + vbOKCancel)
Cancel = (lReply = vbCancel)
If Cancel = False Then Me.Save
Cancel = True
End If
End Sub
‘*****************************************************
示例文档见 (程序46)在工作簿中阻止另存为命令的使用.xls。UploadFiles/2006-9/919340817.rar
程序47:阻止用户打印工作簿
本示例演示当用户试图进行"打印预览"或"打印"时,将弹出不能打印本工作簿的消息框,因而不能对该工作簿进行打印预览或打印操作。
下面的代码放置在ThisWorkbook代码模块中:
‘*****************************************************
Private Sub workbook_BeforePrint(Cancel As Boolean)
Cancel = True
MsgBox "对不起,您不能打印本工作簿.", vbInformation
End Sub
‘*****************************************************
示例文档见 (程序47)阻止用户打印工作簿.xls。UploadFiles/2006-9/919551315.rar
程序48:阻止打印工作簿中的部分工作表
本程序将阻止用户打印工作簿中所指定的部分工作表,即在这些工作表中(如工作表Sheet1和Sheet2)使用“打印预览”和”打印”功能时,将弹出不能打印的消息框。而可以对其它工作表进行正常的打印预览和打印操作。
下面的代码放置在ThisWorkbook代码模块中:
‘*****************************************************
Private Sub workbook_BeforePrint(Cancel As Boolean)
Select Case ActiveSheet.Name
Case "Sheet1", "Sheet2"
Cancel = True
MsgBox "对不起,您不能打印本工作簿中的这个工作表", vbInformation
End Select
End Sub
‘*****************************************************
示例文档见 (程序48)阻止用户打印工作簿中的部分工作表.xls。UploadFiles/2006-9/919298231.rar
程序49:阻止用户在工作簿中添加新工作表
本程序将阻止用户在新工作簿中添加新工作表,即当用户选择插入新工作表命令时,将会弹出不允许添加新工作表的消息框且不能添加新的工作表。
下面的代码放置在ThisWorkbook代码模块中:
‘*****************************************************
Private Sub Workbook_NewSheet(ByVal Sh As Object)
Application.DisplayAlerts = False
MsgBox "对不起,您不能在本工作簿中添加新的工作表", vbInformation
Sh.Delete
Application.DisplayAlerts = True
End Sub
‘*****************************************************
示例文档见 (程序49)阻止用户添加新工作表.xls。UploadFiles/2006-9/919443909.rar
程序50:工作表列A的值改变时,重新排序
在本示例中,如果您对工作表Sheet1中A列的值改变或在A列中添加值,工作表会对A列到D列中的数据进行重新排序(数据是动态的),并相应的行进行调整,同时工作表Sheet2中的数据进行同步更新。
将下面的程序代码输入到工作表Sheet1模块中:
‘*****************************************************
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
Worksheets("Sheet2").Range(Target.Address).Value = Target.Value
Range(("A1"), Cells(Rows.Count, 1).End(xlUp).Offset(0, 3)).Sort _
key1:=Range("A2"), order1:=xlAscending, header:=xlYes
Range("A:D").Copy Worksheets("Sheet2").Range("A:D")
End Sub
‘*****************************************************
示例文档见 (程序50)对A列排序并调整相应的行.xls。UploadFiles/2006-9/919786958.rar
程序51:UCase函数的使用
当您在工作表的A列中输入小写字母时,自动转换成大写字母,使用Ucase函数。
将下面的程序代码输入到工作表Sheet1模块中:
‘*****************************************************
Private Sub Worksheet_Change(ByVal Target As Range)
If IsEmpty(Target) Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column > 1 Then Exit Sub
Application.EnableEvents = False
Target.Value = UCase(Target.Value)
Application.EnableEvents = True
End Sub
‘*****************************************************
示例文档见 程序(51)自动转换成大写.xls。UploadFiles/2006-9/919229786.rar
程序52:自动标记指定单元格所在行的颜色
在本示例中,当您在相应的单元格中输入指定值时,会自动在工作表已使用区域内标记该单元格所在行的颜色;如果您删除相应单元格中的内容,颜色同时消失。参见解析UsedRange属性示例三。
‘*****************************************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Long
For r = UsedRange.Rows.Count To 1 Step -1
If Range("E" & r) = "finish" Then _
Range("A:G").Rows(r).Interior.ColorIndex = 10
Next r
For r = UsedRange.Rows.Count To 1 Step -1
If Range("E" & r) = "" Then _
Range("A:G").Rows(r).Interior.ColorIndex = 2
Next r
End Sub
‘*****************************************************
当然,您可以修改上面的程序,将单元格或内容换成您想要的单元格或内容。
示例文档见 (程序52)自动标识行.xls。UploadFiles/2006-9/919895942.rar
程序53:一个进度条示例
在本示例中,当打开工作簿时会弹出一个窗口并显示进度条和信息。
在VBE编辑器中,插入一个用户窗体并布局,在窗体中有一个图片控件、一个进度条和三个标签。然后写代码如下。
以下为用户窗体中相关控件的代码:
‘*****************************************************
Private Sub UserForm_Initialize()
Label3.Caption = Format(Now, "dddd d mmmm yyyy hh:mm:ss")
End Sub
‘*****************************************************
Private Sub UserForm_Activate()
Dim dTime As Date
Dim i As Integer
For i = 1 To 100 Step 100 / 8
dTime = Now + TimeValue("0:00:01")
Application.Wait TimeValue(dTime)
ProgressBar1.Value = i
Next i
End Sub
‘*****************************************************
Private Sub Label2_Click()
ThisWorkbook.FollowHyperlink "http://fanjy.blog.excelhome.net"
End Sub
‘*****************************************************
以下为工作簿中的代码,实现当工作簿打开时显示用户窗体。
‘*****************************************************
Private Sub Workbook_Open()
Application.OnTime EarliestTime:= _
Now + TimeValue("00:00:08"), Procedure:="EndSplash"
UserForm1.Show
End Sub
‘*****************************************************
卸载用户窗体的代码:
‘*****************************************************
Sub EndSplash()
Unload UserForm1
End Sub
‘*****************************************************
注意,用户窗体等待时间与进度条控制时间应一致。
示例文档见 (程序53)一个进度条示例.xls。UploadFiles/2006-9/919890160.rar
程序54:将公式结果转换为值
本示例将由公式所产生的结果转换为数值,即按要求运行程序后,公式单元格区域将转换成数值。当您再编辑这些区域时,不会显示公式,而是数值。
‘*****************************************************
Sub ValuesOnly()
Dim rRange As Range
On Error Resume Next
Set rRange = Application.InputBox(Prompt:="请选取公式单元格区域", _
Title:="转换为数值", Type:=8)
If rRange Is Nothing Then Exit Sub
rRange = rRange.Value
End Sub
‘*****************************************************