VBA编程问答
(第1辑)
在学习ExcelVBA编程的过程中，经常会遇到一些问题，有些可能是新碰到的，有些则是以前已遇到过但暂时忘掉了解决办法的，VBA编程问答将把我所收集到的问题和自已所遇到的问题及解决办法进行归纳整理，以方便查阅和参考。
在下面的内容中，有大量的程序代码，您可以将它们输入或复制到VBE编辑器中进行调试，也可以将它们进行适当的调整和修改后应用到自已的程序中。有些问答提供了参考示例，您可以直接下载后处理。
本辑目录
问题1：如何传递参数到OnTime方法和OnAction属性所调用的宏程序中？
问题2：如何禁用用户窗体的关闭按钮？
问题3：可以撤销宏所执行的操作吗？
问题4：如何将同一文件夹中的多个文本文件读入到工作簿中？
问题5：如何使用VBA删除所有的空工作表？
问题6：如何获取计算机上可供使用的打印机列表？
问题7：如何基于某个单元格更新其它单元格的日期？
问题8：如何编写一个宏程序运行另一个宏程序特定的次数？
问题9：如何在一个组合框中列出所有工作表中单元格D3中的值？
问题10：如何使工作表中的文本闪烁？
问题11：如何将工作簿中其它工作表名导入到指定的工作表中？
问题12：如何在单元格中快速输入带秒的时间？
========================================================
问题1：当OnTime方法或OnAction属性中设置的所要运行的宏带有参数时，如何传递参数到这些宏程序中？即传递参数到OnTime方法和OnAction属性所调用的宏程序中。
解答：
因为运用Application.OnTime或Object.OnAction调用宏程序的语法基本相似，因此，下面介绍的OnTime方法所使用的语法同样适用于OnAction属性。
为了便于理解，以下介绍均使用一段相似的代码，只不过传递给所调用宏程序MyProcedure的参数不同而已，以此来讲解传递给宏程序不同参数的方法。例如，下面的代码将使MyProcedure宏程序在从现在起的2秒后运行：
Application.OnTime Now + TimeValue("00:00:02"), "MyProcedure"
子问题1：假设MyProcedure宏程序接受参数，如何传递参数到该宏程序中？有下面几种情形：
(1)所调用的宏程序接受一个参数
如果是在正常代码过程中传递参数给宏程序，可以使用" MyProcedure (42)"，其中“42”为传递给MyProcedure程序的参数。但如果这样的传递参数方法用在OnTime方法中，该程序将不会运行。
正确的语法是外层为双引号，内层再加上一组单引号，里面是程序名和程序所接受的参数。如下所示：
'MyProcedure宏程序接受一个数值参数
Application.OnTime Now + TimeValue("00:00:02"), "' MyProcedure 42'"
(2)所调用的宏程序接受多个参数
如果所调用的宏程序接受几个参数，那么在这些参数之间应该用逗号分隔。如下所示：
'MyProcedure宏程序接受两个数值参数
Application.OnTime Now + TimeValue("00:00:02"), "'MyProcedure 42, 13'"
(3)所调用的宏程序接受字符串参数
如果所调用的宏程序所接受的参数是字符串，因为字符串已经带有一对双引号，因此应该将字符串包含在双层双引号中，即字符串参数周围有两对双引号。如下所示：
'MyProcedure宏程序接受一个字符串Hello!作为其参数
Application.OnTime Now + TimeValue("00:00:02"), "'MyProcedure ""Hello!""'"
子问题2：当MyProcedure宏程序所接受的参数是变量，如何传递参数到该宏程序中？
(1)该变量为局部变量，用如下所示的方式。
'MyProcedure宏程序接受一个字符串变量strText参数，该变量为局部变量
strText = "Hello!"
Application.OnTime Now + TimeValue("00:00:02"), "'MyProcedure """ & strText & """'"
(2)该变量为全局变量，用如下所示的方式，即不必加双层双引号。
'MyProcedure宏程序接受一个字符串变量g_strText参数，该变量必须声明为公有的
g_strText = "Hello!"
Application.OnTime Now + TimeValue("00:00:02"), "'MyProcedure g_strText'"
注意，在这种情况下变量必须声明为公共变量，否则MyProcedure宏程序将不能找到该变量参数。
=======================================================
问题2：如何禁用用户窗体的关闭按钮？
解答：您
可能不想用户在单击窗体右上角的X图标后关闭窗体，您可以在用户窗体代码模块中将UserForm_QueryClose过程的Cancel参数值设置为
True，此时虽然X图标仍然存在，但当您单击它时已不起作用，因此可以防止用户通过单击该图标按钮来关闭用户窗体。例如，下面的示例提示用户只能通过单
击用户窗体上的“确定”按钮来关闭该用户窗体。您可以在VBE编辑器中插入一个用户窗体，并在用户窗体上放置一个名为“Ok”的按钮，在用户窗体代码模块
中输入下面的代码进行调试。
‘**************************************************
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
‘CloseMode参数表明事件发生的原因
‘若其值等于vbFormControlMenu则意味着用户单击了X图标按钮
If CloseMode = vbFormControlMenu Then
MsgBox "请单击""确定""按钮关闭本窗体"
Cancel = True
End If
End Sub
‘**************************************************
Private Sub Ok_Click()
Unload UserForm1
End Sub
=======================================================
问题3：可以撤销宏所执行的操作吗？
解答：可以，但不能通过Excel内置的功能自动实现。您可以使用VBA代码记录下运行宏程序前单元格或单元格区域原先的内容，在“撤销”命令中调用以恢复程序运行前的状态。
您可以使用Application对象的OnUndo方法作为宏程序结束前的最后一个代码，该方法允许您指定出现在“撤销”菜单项中的文本以及点击该文本后所运行的过程。如下面的代码所示：
Application.Onundo “撤销最后一个宏”，”恢复宏程序”
为说明上述方法，下面列出了一个完整的示例。示例的完整代码以及代码说明如下：
‘**************************************************
Type RangeCellInfo '自定义类型存储宏运行所作出的改变
CellContent As Variant
CellAddress As String
End Type
Public OrgWB As Workbook
Public OrgWS As Worksheet
Public OrgCells() As RangeCellInfo
‘**************************************************
Sub EditRange()
' 在所有被选取的单元格中插入X
Dim i As Integer, cl As Range
If TypeName(Selection) <> "Range" Then Exit Sub
Application.ScreenUpdating = False
ReDim OrgCells(Selection.Count)
Set OrgWB = ActiveWorkbook
Set OrgWS = ActiveSheet
i = 1
‘记录下宏程序对工作表作出改变前的状态
For Each cl In Selection
OrgCells(i).CellContent = cl.Formula
OrgCells(i).CellAddress = cl.Address
i = i + 1
Next cl
‘在所选单元格中填允X
Selection.Formula = "X"
‘指定在“撤销”菜单项中的文字及选择该命令时所执行的宏程序
Application.OnUndo "撤销最后运行的宏过程操作", "UndoEditRange"
End Sub
‘**************************************************
‘恢复工作表原先的状态
Sub UndoEditRange()
Dim i As Integer
Application.ScreenUpdating = False
On Error GoTo NoWBorWS
OrgWB.Activate
OrgWS.Activate
On Error GoTo 0
'恢复宏运行所作的改变
For i = 1 To UBound(OrgCells)
Range(OrgCells(i).CellAddress).Formula = OrgCells(i).CellContent
Next i
Set OrgWB = Nothing
Set OrgWS = Nothing
Erase OrgCells
NoWBorWS:
End Sub
示例文档见撤销宏示例.xls。UploadFiles/2006-8/81836932.rar
=======================================================
问题4：如何将同一文件夹中的多个文本文件读入到工作簿中？
解答：通
常，我们所看到的例子都是在工作簿中读入一个文本文件中的内容。假设有几个文本文件，我们把它们放在与工作簿相同的文件夹中，那么，现在如何在该工作簿中
一次性读取这几个文本文件的内容。下面的程序演示了上述过程，示例工作簿附后，其中源数据引用了lichaobin网友在他的提问贴中所附的数据。
分两种情况：
(一)所读入的文本文件总行数小于65536行，您可以使用以下代码。
‘**************************************************
Sub Sample1()
Dim n As Long, a(), ff As Integer, txt As String, myDir As String, x
Dim myF As String, i As Long
myDir = ThisWorkbook.Path & Application.PathSeparator
myF = Dir(myDir & "*.txt")
Do While myF <> ""
ff = FreeFile
Open myDir & myF For Input As #ff
Do While Not EOF(ff)
Line Input #ff, txt
x = Split(txt, "|")
n = n + 1
ReDim Preserve a(1 To n)
a(n) = x
Loop
Close #ff
myF = Dir()
Loop
Cells.Clear
With ThisWorkbook.Worksheets("Sheet1").Range("a1")
For i = 1 To UBound(a)
.Offset(i - 1).Resize(, UBound(a(i)) + 1) = a(i)
Next
End With
End Sub
‘**************************************************
(二)所读入的文本文件总行数大于65536行，您可以使用以下代码。其中使用了一个变量t和一个判断语句，当多于65536行时，将剩下的数据写入另一工作表中。
Sub Sample2()
Dim n As Long, a(), ff As Integer, txt As String, myDir As String, x
Dim myF As String, i As Long, t As Integer
t = 1
myDir = ThisWorkbook.Path & Application.PathSeparator
myF = Dir(myDir & "*.txt")
Do While myF <> ""
ff = FreeFile
Open myDir & myF For Input As #ff
Do While Not EOF(ff)
Line Input #ff, txt
x = Split(txt, "|")
n = n + 1
ReDim Preserve a(1 To n)
a(n) = x
If n = 65536 Then
With ThisWorkbook.Sheets(t).Range("a1")
For i = 1 To UBound(a)
.Offset(i - 1).Resize(, UBound(a(i)) + 1) = a(i)
Next
End With
n = 0: Erase a: t = t + 1
End If
Loop
Close #ff
myF = Dir()
Loop
If n > 0 Then
With ThisWorkbook.Sheets(t).Range("a1")
For i = 1 To UBound(a)
.Offset(i - 1).Resize(, UBound(a(i)) + 1) = a(i)
Next
End With
End If
End Sub
示例文档见读取多个文本文件.rar。UploadFiles/2006-8/81152126.rar
=======================================================
问题5：如何使用VBA删除所有的空工作表？
解答：可以分两种情形来对待。
(一)如果您想删除同一工作簿中的所有空工作表，可以使用下面的两个程序中的其中一个：
‘**************************************************
Sub test1()
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
If ActiveWorkbook.Worksheets.Count > 1 Then
If IsEmpty(ActiveSheet.UsedRange) Then
ws.Delete
End If
End If
Next ws
Application.DisplayAlerts = True
End Sub
‘**************************************************
Sub test2()
Dim ws As Worksheet
On Error GoTo Handdle
Application.DisplayAlerts = False
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
With ws
If Application.CountA(.Cells) = 0 Then
.Delete
End If
End With
Next ws
Handdle:
Application.DisplayAlerts = True
End Sub
(二)如果您想删除已打开的工作簿中的所有空工作表，可使用下面的程序：
‘**************************************************
Sub test()
Dim ws As Worksheet
Dim wb As Workbook
Application.DisplayAlerts = False
For Each wb In Workbooks
wb.Activate
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
If ActiveWorkbook.Worksheets.Count > 1 Then
If IsEmpty(ActiveSheet.UsedRange) Then
ws.Delete
End If
End If
Next ws
Next wb
Application.DisplayAlerts = True
End Sub
=======================================================
问题6：如何获取计算机上可供使用的打印机列表？
解答：您可能有时想获取您的计算机上可供使用的打印机列表，然后从中选择打印机输出。最简单的方法是，您可以在代码中添加下面的语句：
Application.Dialogs(xlDialogPrint).Show
=======================================================
问题7：如何基于某个单元格更新其它单元格的日期？
例
如：我需要做的一个例行工作是依赖于两个特定单元格的内容添加一些日期到另一个单元格。例如，在单元格J2中有W(代表每周)或者B(代表Bi周)或者M
(代表每月)，单元格N2中的内容为一个可更新的日期，如果J2中包含一个W我需要在单元格L2中添加7天，或者如果J2中包含一个B我需要在单元格L2
中添加14天，或者如果J2中包含一个M则在单元格L2中添加30天，……在单元格J2中包含的信息W,B,或M决定计算的天数，单元格N2中包含原先约
定的日期作为开始计算的日期，单元格L2中的这个日期基于上面两个单元格的日期更新。
解答：可以粘贴下面的两个程序之一到工作表代码模块中。
(一)区分大小写，您必须在工作表中输入大写的字母W、B或M。
‘**************************************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Range("J2").Text = "W" Then
Range("L2") = Range("N2").Value + 7
ElseIf Range("J2").Text = "B" Then
Range("L2") = Range("N2").Value + 14
ElseIf Range("J2").Text = "M" Then
Range("L2") = Range("N2").Value + 30
End If
End Sub
(二)不区分大小写，并使用了Select Case选择语句。
‘**************************************************
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$N$2" Or Target.Address = "$J$2" Then
Dim iDays As Byte
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
Select Case UCase(Range("J2").Value)
Case "W"
iDays = 7
Case "B"
iDays = 14
Case "M"
iDays = 30
End Select
Range("L2").Value = Range("N2").Value + iDays
Application.EnableEvents = True
Exit Sub
ERRORHANDLER:
Application.EnableEvents = True
End If
End Sub
=======================================================
问题8：如何编写一个宏程序运行另一个宏程序特定的次数？
解答：可以用一个简单的循环来实现。
‘**************************************************
Sub FirstMacro()
Dim RunCount as Long
Const RunMax As Long=10 ‘定义要运行的次数
For RunCount =1 To RunMax
Call SecondMacro ‘调用要运行的宏程序
Next
End Sub
=========================================================
问题10：如何在一个组合框中列出所有工作表中单元格D3中的值？
解答：假设用户窗体中有一个名为ComboBox1的组合框，您可在用户窗体中添加以下代码，当用户窗体被激活时，在组合框中将显示出所有工作表中单元格D3的值。
‘**************************************************
Private Sub UserForm_Activate()
Dim ws As Worksheet
For Each ws In Worksheets
ComboBox1.AddItem ws.Range("D3").Text
Next ws
End Sub
=======================================================
问题10：如何使工作表中的文本闪烁？
解答：为了使文本闪烁，您需要周期性地执行一个程序来变换文本的前景色，OnTime方法可以用于周期性地运行一个程序。
‘**************************************************
Public RunWhen As Double
Sub StartBlink()
If Range("A1").Font.ColorIndex = 2 Then
Range("A1").Font.ColorIndex = xlColorIndexAutomatic
Else
Range("A1").Font.ColorIndex = 2
End If
RunWhen = Now + TimeSerial(0, 0, 1)
Application.OnTime RunWhen, "StartBlink", , True
End Sub
‘**************************************************
Sub StopBlink()
Range("A1").Font.ColorIndex = xlColorIndexAutomatic
Application.OnTime RunWhen, "StartBlink", , False
End Sub
在上面的这些程序中，您可以改变参数A1为您想要使文本闪烁的单元格或单元格区域。在工作簿打开时，您需要初始化这个程序，因此，您可以放置下面的代码到ThisWorkbook代码模块中。
‘**************************************************
Private Sub Workbook_Open()
StartBlink
End Sub
当工作簿关闭时，您需要取消OnTime事件，因此，您需要放置下面的代码到ThisWorkbook代码模块中。
‘**************************************************
Private Sub Workbook_BeforeClose(Cancel As Boolean)
StopBlink
End Sub
示例文档见在Excel中闪烁文本.xls。UploadFiles/2006-8/81151110.rar
=======================================================
问题11：如何将工作簿中其它工作表名导入到指定的工作表中？
解答：本问题即将工作簿中除指定的工作表(如名为Name的工作表)外的其它的工作表名导入到指定的工作表中(即Name工作表中)。您可以使用下面的代码。
‘**************************************************
Sub Test()
Dim ws As Worksheet
Dim i As Long, j As Long
Worksheets("Name").Range("A:A").Clear
i = Worksheets("Name").Range("A65536").End(xlUp).Row
For Each ws In Worksheets
If ws.Name <> "Name" Then
Worksheets("Name").Cells(i, 1) = ws.Name
i = Worksheets("Name").Range("A65536").End(xlUp).Row + 1
End If
Next ws
End Sub
=======================================================
问题12：如何在单元格中快速输入带秒的时间？
解答：一
般，在Excel中快速输入日期和时间时，可使用快捷键，即按Ctrl+:组合键将快速在单元格中输入当前日期，按Ctrl+Shift+:组合键将快速
在单元格中输入当前时间，但所显示的时间为“小时：分钟”格式，不会显示秒。如果您想显示“小时：分钟：秒”这样的格式的话，可以使用Onkey方法修改
快捷键的缺省设置，如下所示，运行“设置快捷键”代码即可。
‘**************************************************
Sub 设置快捷键()
Application.OnKey "+^:", "输入时间"
End Sub
‘**************************************************
Sub 恢复快捷键()
Application.OnKey "+^:"
End Sub
‘**************************************************
Sub 输入时间()
With ActiveCell
.Value = Time()
.NumberFormat = "hh:mm:ss"
End With
End Sub
如果您想恢复快捷键的缺省设置，运行“恢复快捷键”过程。
By fanjy in 2006-8-1