VBA编程问答第3辑

《VBA编程问答第3辑》由会员分享，可在线阅读，更多相关《VBA编程问答第3辑（19页珍藏版）》请在金锄头文库上搜索。

1、VBA 编程问答 （第 3 辑 ）VBA 编程问答 （第 3 辑 ）fanjy 发表于 2007-1-20 20:18:00 500）this.resized=true;this.style.width=500; 在学习 ExcelVBA 编程的过程中，经常会遇到一些问题，有些可能 是新碰到的，有些则是以前已遇到过但暂时忘掉了解决办法 的，VBA编程问答将把我所收集到的问题和自已所遇到的问 题及解决办法进行归纳整理，以方便查阅和参考。 在下面的内容中，有大量的程序代码，并附有简单的说明， 您可以将它们输入或复制到 VBE 编辑器中进行调试，也可 以将它们进行适当的调整和修改后应用到自已的程序中

2、。有 些问答提供了参考示例，您可以直接下载后处理。本辑目录问题 26 ：如何实现单元格在指定区域内自动跳转 ?问题 27：如何将多个工作簿中的工作表一次性合到一个工作 簿里面？问题 28 ：关于 Excel 单元格填充颜色 ？问题 29 ：如何实现在 Sheet1 中输入后，在 Sheet2 中相应 的单元格中显示？问题 30 ：如何实现当某一单元格满足非空条件时， 输入的数 据不能修改？问题 31 ：如何用 Vba 方法导出 Xls 文件至 Txt 文件？问题 26 ：如何实现单元格在指定区域内自动跳转?例如，在单元格区域 A1 ：C100 中，无论何时在其中的某个 单元格中输入完一个单个的

3、字符后，自动按规律跳转到下一 单元格，即在单元格 B1 中输完后，跳转到单元格 C1 ，在单 元格 C1 中输入完单个字符后，自动跳转到单元格 A2 ， ……解答：可以在工作表事件中使用下面的代码：‘ ;*Private Sub Worksheet_Change(ByVal Target As Range)Const WS_RANGE As String = A1:C100 <= 按 需要改变单元格区域On Error GoTo ws_exitApplication.EnableEvents = FalseIf Not Intersect(Target,

4、 Me.Range(WS_RANGE) Is Nothing ThenWith TargetIf Len(.Value) = 1 ThenMe.Cells(.Row - (.Column Mod 3 =0), .Column Mod 3 + 1).SelectIf Intersect(ActiveCell,Me.Range(WS_RANGE) Is Nothing ThenMe.Range(WS_RANGE).Cells(1,1).SelectEnd IfEnd IfEnd WithEnd Ifws_exit:Application.EnableEvents = TrueEnd Sub 

5、216 ;* 说明：该代码中的单元格区域可按您的需要改为合适的单元 格区域，但必须是 3 列。不限于列的代码如下：‘*Private Sub Worksheet_Change(ByVal Target As Range)Dim Rng As RangeDim Ix As Long, Ad As StringSet Rng = Range(F4:G50) <= 按需要改变单元格 区域On Error GoTo ws_exitApplication.EnableEvents = FalseIf Not Intersect(Target, Rng) Is Nothing ThenI

6、f Len(Target.Value) = 1 ThenAd = Target.Address(False, False, xlR1C1, , Rng)Ix = Val(Mid(Ad, 3) * Rng.Columns.Count + Val(Mid(Ad, InStr(Ad, C) + 2) + 1Rng(Ix Mod Rng.Cells.Count) + 1).Select End IfEnd Ifws_exit:Application.EnableEvents = TrueEnd Sub‘ ;* 说明：上面的代码中，单元格区域可不限于 2 列。问题 27 ：如何将多个工作簿中的

7、工作表一次性合到一个工作 簿里面？解答：关于如何将多个工作簿( xls 文件)中的工作表 (worksheet )复制到同一个工作簿中的解决。下面的代码可 以将某个磁盘目录下的多个 xls 文件的复制到含有这段代码 的 xls 文件中，而且 xls 文件可以根据处理 worksheet 的数 量自动的增加 xls 文件中 worksheet 的数量。使用时将代码 复制到 xls 文件的宏内，然后运行宏 main 即可。 代码中运用了 filesystemobject 对象和 excel 的 range 对象 的 copy 方法以及 worksheet 和 workbook 对象的 add 方法

8、。 这里就不在赘述，可以在 excel vba 的帮助中找到。‘ ;*Sub Mergesheet(ByVal sPath As String)Dim fs, fd, fl As ObjectDim xlbook As WorkbookDim xlsheet As WorksheetDim i_cnt As Integeri_cnt = 1Set fs = CreateObject(scripting.filesystemobject) 建立filesystemobjectIf Not fs.FolderExists(sPath) ThenMsgBox 目录不存在！ , vbCrit

9、icalExit SubEnd IfSet 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).Workshee

10、ts.AddElse Set xlsheet =Application.Workbooks(1).Worksheets(i_cnt)End Ifxlbook.Worksheets(1).Rows.Copy xlsheet.Cells(1,1) 复制 worksheeti_cnt = i_cnt + 1xlbook.Close关闭已经打开的 xls 文件End IfNextSet fl = Nothing关闭file,folder,filesystemobject Set fd = Nothing对象Set fs = NothingEnd SubSub main()Dim sPath As St

11、ringsPath = InputBox( 请输入目录！如 C:, 合并目录下 xls 文件的 sheet1) 显示输入框获取磁盘目录If sPath = Then Exit SubMergesheet (sPath)End Sub‘ ;*问题 28：关于 Excel 单元格填充颜色 ？有五种可能的计算结果，比如结果会是 1,2,3,4,5 ，不同的值 给单元格填充不同颜色。条件格式最多只能定义三个条件， 即只能填充最多三种颜色，不知用什么方法可以填上三种以 上的颜色？解答： 如果所有的结果集合只是在 1，2，3，4，5 中间， 那么写个宏就 OK 。假设对于 $B 这一整列的情况如

12、下：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 ̵

13、6; 要填充颜色的单元格，可修改 为所需要的Range(B + CStr(i).SelectSelect Case Range(B + CStr(i).Cells.ValueCase 1Selection.Interior.ColorIndex = 3Case 2Selection.Interior.ColorIndex = 4Case 3Selection.Interior.ColorIndex = 5Case 4Selection.Interior.ColorIndex = 6Case 5Selection.Interior.ColorIndex = 7End SelectWith Sel

14、ection.Interior.Pattern = xlSolid.PatternColorIndex = xlAutomaticEnd WithNextEnd Sub *如果要做到单元格的值改变后填充的颜色自动更新，这个宏 该改成怎样？如果单元格的值是计算得来的，用 worksheet Calculate Event 应该可以。代码： ‘ ;* Private Sub Worksheet_Calculate()Dim vValue As IntegerDim vColor As IntegerDim cRange As RangeDim cell As RangeFor Each cell In Intersect(Columns(B), ActiveSheet.UsedRange) vValue = cell.Value 默认值无填充色 vColor = 0Select Case vValue Case