VBA编程问答(第3辑)

fanjy 发表于 2007-1-20 20:18:00
在学习ExcelVBA编程的过程中，经常会遇到一些问题，有些可能是新碰到的，有些则是以前已遇到过但暂时忘掉了解决办法的，VBA编程问答将把我所收集到的问题和自已所遇到的问题及解决办法进行归纳整理，以方便查阅和参考。
在下面的内容中，有大量的程序代码，并附有简单的说明，您可以将它们输入或复制到VBE编辑器中进行调试，也可以将它们进行适当的调整和修改后应用到自已的程序中。有些问答提供了参考示例，您可以直接下载后处理。
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
本辑目录
问题26：如何实现单元格在指定区域内自动跳转?
问题27：如何将多个工作簿中的工作表一次性合到一个工作簿里面？
问题28：关于Excel单元格填充颜色......？
问题29：如何实现在Sheet1中输入后，在Sheet2中相应的单元格中显示？
问题30：如何实现当某一单元格满足非空条件时，输入的数据不能修改？
问题31：如何用Vba方法导出Xls文件至Txt文件？
=====================================================================
问题26：如何实现单元格在指定区域内自动跳转?
例如，在单元格区域A1：C100中，无论何时在其中的某个单元格中输入完一个单个的字符后，自动按规律跳转到下一单元格，即在单元格B1中输完后，跳转到单元格C1，在单元格C1中输入完单个字符后，自动跳转到单元格A2，……
解答：可以在工作表事件中使用下面的代码：
‘***********************************
Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "A1:C100" '<== 按需要改变单元格区域
On Error GoTo ws_exit
Application.EnableEvents = False
If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
With Target
If Len(.Value) = 1 Then
Me.Cells(.Row - (.Column Mod 3 = 0), .Column Mod 3 + 1).Select
If Intersect(ActiveCell, Me.Range(WS_RANGE)) Is Nothing Then
Me.Range(WS_RANGE).Cells(1, 1).Select
End If
End If
End With
End If
ws_exit:
Application.EnableEvents = True
End Sub
‘***********************************
说明：该代码中的单元格区域可按您的需要改为合适的单元格区域，但必须是3列。
不限于列的代码如下：
‘***********************************
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Dim Ix As Long, Ad As String
Set Rng = Range("F4:G50") '<== 按需要改变单元格区域
On Error GoTo ws_exit
Application.EnableEvents = False
If Not Intersect(Target, Rng) Is Nothing Then
If Len(Target.Value) = 1 Then
Ad = Target.Address(False, False, xlR1C1, , Rng)
Ix = Val(Mid(Ad, 3)) * Rng.Columns.Count + Val(Mid(Ad, InStr(Ad, "C") + 2)) + 1
Rng((Ix Mod Rng.Cells.Count) + 1).Select
End If
End If
ws_exit:
Application.EnableEvents = True
End Sub
‘***********************************
说明：上面的代码中，单元格区域可不限于2列。
=====================================================================
问题27：如何将多个工作簿中的工作表一次性合到一个工作簿里面？
解答：关于如何将多个工作簿（xls文件）中的工作表(worksheet）复制到同一个工作簿中的解决。下面的代码可以将某个磁盘目录下的多个xls文件的复制到含有这段代码的xls文件中，而且xls文件可以根据处理worksheet的数量自动的增加xls文件中worksheet的数量。使用时将代码复制到xls文件的宏内，然后运行宏main即可。
代码中运用了filesystemobject对象和excel的range对象的copy方法以及worksheet和workbook对象的add方法。这里就不在赘述，可以在excel vba的帮助中找到。
‘***********************************
Sub Mergesheet(ByVal sPath As String)
Dim fs, fd, fl As Object
Dim xlbook As Workbook
Dim xlsheet As Worksheet
Dim i_cnt As Integer
i_cnt = 1
Set fs = CreateObject("scripting.filesystemobject") '建立filesystemobject
If Not fs.FolderExists(sPath) Then
MsgBox "目录不存在！", vbCritical
Exit Sub
End If
Set fd = fs.getfolder(sPath)   '或取文件夹
For Each fl In fd.Files        '依此处理文件夹中的文件
If Right(Trim(fl.Name), 3) = "xls" Then     '只处理xls文件
Set xlbook = Application.Workbooks.Open(sPath + "\" + fl.Name)  '打开xls文件
If i_cnt <> 3 Then         '默认的worksheet数量是3,如果超过就自动的增加
Set xlsheet = Application.Workbooks(1).Worksheets.Add
Else
Set xlsheet = Application.Workbooks(1).Worksheets(i_cnt)
End If
xlbook.Worksheets(1).Rows.Copy xlsheet.Cells(1, 1) '复制worksheet
i_cnt = i_cnt + 1
xlbook.Close             '关闭已经打开的xls文件
End If
Next
Set fl = Nothing           '关闭file,folder,filesystemobject对象
Set fd = Nothing
Set fs = Nothing
End Sub
Sub main()
Dim sPath As String
sPath = InputBox("请输入目录！如C:", "合并目录下xls文件的sheet1")  '显示输入框获取磁盘目录
If sPath = " " Then Exit Sub
Mergesheet (sPath)
End Sub
‘***********************************
===================================================================
问题28：关于Excel单元格填充颜色......？
有五种可能的计算结果，比如结果会是1,2,3,4,5，不同的值给单元格填充不同颜色。条件格式最多只能定义三个条件，即只能填充最多三种颜色，不知用什么方法可以填上三种以上的颜色？
解答： 如果所有的结果集合只是在1，2，3，4，5中间，那么写个宏就OK。
假设对于$B这一整列的情况如下：
B1=0或空时，单元格B1无填充颜色；
B1=1 时，给单元格B1填充红色；
B1=2 时，给单元格B1填充蓝色；
B1=3 时，给单元格B1填充绿色；
B1=4 时，给单元格B1填充黄色；
B1=5 时，给单元格B1填充紫色。
B2=0或空时，单元格B2无填充颜色；
B2=1 时，给单元格B2填充红色；
B2=2 时，给单元格B2填充蓝色；
B2=3 时，给单元格B2填充绿色；
B2=4 时，给单元格B2填充黄色；
B2=5 时，给单元格B2填充紫色。
……
代码：
‘***********************************
Sub Macro1()
For i = 1 To 4096 ‘要填充颜色的单元格，可修改为所需要的
Range("B" + CStr(i)).Select
Select Case Range("B" + CStr(i)).Cells.Value
Case 1
Selection.Interior.ColorIndex = 3
Case 2
Selection.Interior.ColorIndex = 4
Case 3
Selection.Interior.ColorIndex = 5
Case 4
Selection.Interior.ColorIndex = 6
Case 5
Selection.Interior.ColorIndex = 7
End Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
Next
End Sub
‘***********************************
---------------------------------------------------------------------
如果要做到单元格的值改变后填充的颜色自动更新，这个宏该改成怎样？
如果单元格的值是计算得来的，用 worksheet Calculate Event 应该可以。
代码：
‘***********************************
Private Sub Worksheet_Calculate()
Dim vValue As Integer
Dim vColor As Integer
Dim cRange As Range
Dim cell As Range
For Each cell In Intersect(Columns("B"), ActiveSheet.UsedRange)
vValue = cell.Value
'默认值无填充色
vColor = 0
Select Case vValue
Case 1
vColor = 3
Case 2
vColor = 5
Case 3
vColor = 4
Case 4
vColor = 6
Case 5
vColor = 13
End Select
Application.EnableEvents = False
cell.Interior.ColorIndex = vColor
Application.EnableEvents = True
Next cell
End Sub
‘***********************************
( 如果单元格的值不是计算得来的，是直接输入的，可以改用 Worksheet Change Event )
---------------------------------------------------------------------
还想问一下，这个宏的功能能否用自定义函数做到？
想用自定义函数的原因：单元格锁定时，自定义函数依然可以正常运行，而宏不行。
这个可以利用 UserInterfaceOnly ＝ TRUE 参数去解决。将 UserInterfaceOnly 参数设置为 True 可以允许通过代码修改，但是不允许通过用户界面修改。默认值为 False，这意味着通过代码和用户界面项都不可以修改受保护的工作表。这个属性设置只适用于当前会话。如果您想让代码可以在任何会话中都可以操作工作表，那么您需要每次工作簿打开的时候添加设置这个属性的代码。
注意红色那段字，由于这个原因，所以加一个宏在 workbook open event 让每次开启档案时去设定UserInterfaceOnly 参数。
代码；
‘***********************************
Private Sub Workbook_Open()
'如果每个工作表都有不同的密码
Sheets(1).Protect Password:="secret1", UserInterFaceOnly:=True
Sheets(2).Protect Password:="secret2", UserInterFaceOnly:=True
'按需要重复
'**如果所有工作表密码相同
'Dim wSheet As Worksheet
'For Each wSheet In Worksheets
'    wSheet.Protect Password:="secret", UserInterFaceOnly:=True
'Next wSheet
'****
End Sub
‘***********************************
必须了解的一些相关概念(陈希章,微软中文新闻组专家)
一般我们在指定颜色时喜欢用ColorIndex这个属性,通常情况下是没有问题的。
但必须知道的一些概念是:ColorIndex是相对于调色盘中(调色盘有56中颜色)的某个位置的颜色,而调色盘是属于工作簿级的对象,也就是说很有可能这样一种情况就是,在这个工作簿中3代表红色(假设),而到另一个工作簿中却不是。
所以,如果要精确定义颜色,是不推荐用ColorIndex的,往往有些同志在调试程序时的疑惑也在于此(明明在自己电脑上是红色,到用户电脑上就不是了)。
还有两种方法来返回颜色：
1.用Excel常量,如vbred,vbblue,vbgreen等。
2.用RGB函数。
用以上的方法,VBA语句也应相应更改。
例:Target.Offset(0, 1).Interior.ColorIndex = vColor 改成'Target.Offset(0, 1).Interior.Color = vbred 等等。
另从本例而言,建议统一用change事件。
===================================================================
问题29：如何实现在Sheet1中输入后，在Sheet2中相应的单元格中显示？
即，如何实现在
sheet1中输入a1=abc，sheet2中显示a1=abc;
输入b1=xyz，sheet2中显示a2=xyz;
再输入a2=123，sheet2中显示a5=123;
输入b2=qwe, sheet2中显示a6=qwe;
不停的输入后，sheet2中数字每四行四行不停填充。
解答：
代码说明，这个需求的关键是，需要建立sheet1的行列值与sheet2的行值之间的函数关系，综合看就是一个代数系统内的等差数列的关系。 这个代数式就是：
j=(i-1)*4+t   j代表sheet2的行值，i代表sheet1的行值，t代表sheet1的列值。
所以能够按照所描述的功能的vba代码如下：
‘***********************************
'这是sheet1的worksheet_change事件(触发的条件就是在sheet1输入数据)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 2 Then   '这里限定最大只可以输入到每行的第2列,否则就不处理
MsgBox "输错了位置", vbCritical '这里是错误的提示信息
Exit Sub                         '退出代码的执行
End If
'按照sheet1与sheet2行列的特定算法填充数据
Sheet2.Cells((Target.Row - 1) * 4 + Target.Column, 1) = Target.Value
End Sub
‘***********************************
===================================================================
问题30：如何实现当某一单元格满足非空条件时，输入的数据不能修改？
如果在excel中写如此要求的一个函数：某一单元格满足非空条件时，输入的数据不能修改。就是当我往一个单元格内输入数据后，其中的数据无法再次修改！
解答：代码如下：
‘***********************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
If Target <> "" Then
Target.Locked = True
ActiveSheet.Protect password:="123"
End If
If Target = "" Then
ActiveSheet.Unprotect password:="123"
End If
End Sub
‘***********************************
===================================================================
问题31：如何用Vba方法导出Xls文件至Txt文件？
即如何以一定的格式输出Excel文件的数据。
解答：
这是个常见的问题，因为许多不同应用系统之间报送数据时，最好的方法就是报送统一格式的数据文件，而带有特殊分割符号的文本文件应该说是最适用的。
下面的代码将输出的文件改为“文件名”+“Worksheet名”组合的TXT文件。代码的适当说明：生成Txt文件需要使用FileSystemObject对象，关于该对象的说明，可以参阅msdn或vba帮助中的相关内容。这段程序可以在将xls文件中任意的sheet中的内容导出成txt文本文件。
如下就是代码。可以将其复制到任何一个xls文件中。使用时，只要打开某个sheet，然后运行这个宏（菜单内：工具-〉宏-〉运行宏OutPutXlsToTxt），即可将该sheet内的数据导出生成TXT文件，文件名是由Excel文件名和Sheet名组合而成的。
‘***********************************
Sub OutPutXlsToTxt()
Dim fs, myFile As Object
Dim i_row, i_col, i_MaxCol As Integer 'xls工作表的行列坐标变量和最大列数变量
Dim myfileline As String'txtfile的行数据
Set fs = CreateObject("Scripting.FileSystemObject")  '建立filesytemobject
'通过filesystemobject新建一个和xls文件同名的txt文件
Set myFile = fs.createtextfile(Workbooks(1).Path + "\" + _
Mid(Trim(Workbooks(1).Name), 1, Len(Trim(Workbooks(1).Name)) - 4) + "之" + _
Trim(Workbooks(1).ActiveSheet.Name) + ".txt")
i_row = 1
i_MaxCol = 0
Do
i_MaxCol = i_MaxCol + 1
Loop Until Workbooks(1).ActiveSheet.Cells(1, i_MaxCol) = ""
i_MaxCol = i_MaxCol - 1    '获得整个sheet的最大列数
If i_MaxCol = 0 Then       '对没有数据的表不做处理并退出程序
MsgBox "该表无数据,不能导出!", vbCritical
Exit Sub
End If
Do
myfileline = ""
For i_col = 1 To i_MaxCol
myfileline = myfileline + _
Trim(CStr(Workbooks(1).ActiveSheet.Cells(i_row, i_col))) + "," '生成每行数据
Next
myFile.writeline (Mid(myfileline, 1, Len(myfileline) - 1))  '将每行数据写入txtfile
i_row = i_row + 1
Loop Until Workbooks(1).ActiveSheet.Cells(i_row, 1) = ""
Set myFile = Nothing
Set fs = Nothing                   '关闭文件和filesystemobject对象
End Sub
‘***********************************
By fanjy in 2007-1-20
注：本辑编程问答资源整理归纳于vbaexpress、微软中文技术社区等。