VBA编程问答 (第2辑) 在学习ExcelVBA编程的过程中,经常会遇到一些问题,有些可能是新碰到的,有些则是以前已遇到过但暂时忘掉了解决办法的,VBA编程问答将把我所收集到的问题和自已所遇到的问题及解决办法进行归纳整理,以方便查阅和参考。 在下面的内容中,有大量的程序代码,并附有简单的说明,您可以将它们输入或复制到VBE编辑器中进行调试,也可以将它们进行适当的调整和修改后应用到自已的程序中。有些问答提供了参考示例,您可以直接下载后处理。 本辑目录 问题14:如何确定一列中带有数据的最后一个单元格? 问题15:如何将一个组合框中的项目筛选至另一个组合框中?(不使用组合框) 问题16:如何将一个组合框中的项目筛选至另一个组合框中?(使用组合框) 问题17:如何允许用户去选择一个文件夹或者目录? 问题18:如何查找应用工作表公式后出现错误的单元格? 问题19:如何查找工作表中的最后一行? 问题20:如何定位某个特定的单元格为屏幕左上角的单元格? 问题21:如何添加自定义工具条? 问题22:在执行Application.Quit命令后,如何避免出现保存警告信息框? 问题23:如何确定单元格背景颜色的名称或者索引号? 问题24:如何查找两个值之间的值? 问题25:如何在一个单元格区域获取两个给定数值之间的最大数值? ===================================================================== 问题14:如何确定一列中带有数据的最后一个单元格? 解答:这里编写了一个通用函数,您可以调用,从而返回您指定的列中的最后单元格。 ‘*********************************** Function LastRowInColumn(intCol As Integer) As Integer On Error GoTo LRICError Application.Volatile '确保工作表发生变化时调用该函数 ‘通用代码Rows.Count表示工作表行数 LastRowInColumn = Cells(Rows.Count, intCol).End(xlUp).Row ExitFnxn: Exit Function '如果出错,则返回错误值到最后的单元格中 LRICError: LastRowInColumn = CVErr(xlErrNA) Resume ExitFnxn End Function ‘*********************************** 您可以在工作表中输入以下测试代码对上面的函数进行测试。 ‘*********************************** Sub test() Dim X As Integer ‘指定确定第2列中的最后一个单元格 X = LastRowInColumn(2) Debug.Print X End Sub ‘*********************************** 示例文档见(问题14)确定某列中的最后单元格.xls。UploadFiles/2006-8/83708035.rar ===================================================================== 问题15:如何将一个组合框中的项目筛选至另一个组合框中?(不使用组合框) 解答:通过后附的示例工作表来说明。在这个示例中,我们没有真正的使用组合框,实际上使用的是数据有效性选项。 当用户在单元格B1中选择公司时,单元格C1将自动列出有效的值,确保显示该公司中雇员名。但您要输入如下的代码在工作表Sheet1模块中: ‘*********************************** Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$B$1" Then FilterList End If End Sub ‘*********************************** 在标准模块中输入以下代码: ‘*********************************** Sub FilterList() Dim strList As String, strCompany As String, strEmployee As String On Error GoTo FilterListError strCompany = Range("B1").Text Select Case strCompany Case "Apple" strList = "=$F$2:$F$6" Case "IBM" strList = "=$G$2:$G$4" Case "Microsoft" strList = "=$H$2:$H$4" End Select With Range("C1").Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=strList .IgnoreBlank = True .InCellDropdown = True .InputTitle = "" .ErrorTitle = "无效雇员名" .InputMessage = "" .ErrorMessage = "请从列表中选择一个雇员名" .ShowInput = False .ShowError = True End With strEmployee = Range("C1").Text '移除'='号 strList = Mid(strList, 2) '确保当前雇员名是在特定的公司,如果不是,从列表中取该公司的第一个雇员名 If Not IsTextInList(strEmployee, Range(strList)) Then Range("C1") = PickFirstEmployee(Range(strList)) End If FilterListError: Exit Sub End Sub ‘*********************************** Function IsTextInList(TextToFind As String, R As Range) As Boolean Dim FirstRow As Integer, LastRow As Integer, iRow As Integer Dim blnFound As Boolean, iCol As Integer FirstRow = R.Row LastRow = FirstRow + R.Rows.Count - 1 iCol = R.Column blnFound = False For iRow = FirstRow To LastRow If Cells(iRow, iCol).Text = TextToFind Then blnFound = True Exit For End If Next iRow IsTextInList = blnFound End Function ‘*********************************** Function PickFirstEmployee(R As Range) As String Dim iRow As Integer, iCol As Integer iRow = R.Row iCol = R.Column PickFirstEmployee = Cells(iRow, iCol).Text End Function ‘*********************************** 示例文档见(问题15)筛选一个组合框中的值到另一个组合框中.xls。UploadFiles/2006-8/83992704.rar =================================================================== 问题16:如何将一个组合框中的项目筛选至另一个组合框中?(使用组合框) 解答:通过后附的示例工作表来说明。在这个工作表中,单击按钮会出现一个“组合框链接”用户窗体,在第一个组合框中选择不同的选项,在第二个组合框中的项目相应发生变化。 在VBE编辑器中,设计一个带有两个组合框(名称分别为cboCategory和cboChoices)的用户窗体,并在窗体模块中输入如下代码: ‘*********************************** Sub UpdatecboChoices() Select Case cboCategory.Text Case "颜色" cboChoices.RowSource = "A2:A6" Case "交通工具" cboChoices.RowSource = "B2:B5" Case "大洲" cboChoices.RowSource = "C2:C8" Case Else cboChoices.List = "" End Select cboChoices.ListIndex = 0 End Sub ‘*********************************** Private Sub cboCategory_Change() UpdatecboChoices End Sub ‘*********************************** Private Sub UserForm_Activate() Dim i As Integer cboCategory.Clear For i = 1 To 3 cboCategory.AddItem Cells(1, i) Next i cboCategory.ListIndex = 0 End Sub ‘*********************************** 示例文档见(问题16)筛选一个组合框中的值到另一个组合框中.xls。UploadFiles/2006-8/83551438.rar =================================================================== 问题17:如何允许用户去选择一个文件夹或者目录? 解答:下面是运用Windows对话框允许用户选取一个文件夹目录的代码: ‘*********************************** Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type ‘*********************************** 'API声明 Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long ‘*********************************** '下面的函数出现让用户选择文件目录的一个窗体 Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim path As String Dim r As Long, X As Long, i As Integer ' 设置根目录为桌面 bInfo.pidlRoot = 0& '设置对话框标题 If IsMissing(Msg) Then bInfo.lpszTitle = "请选择一个文件夹." Else bInfo.lpszTitle = Msg End If '返回的目录类型 bInfo.ulFlags = &H1 '显示对话框 X = SHBrowseForFolder(bInfo) '分析结果 path = Space$(512) r = SHGetPathFromIDList(ByVal X, ByVal path) If r Then i = InStr(path, Chr$(0)) GetDirectory = Left(path, i - 1) Else GetDirectory = "" End If End Function ‘*********************************** 示例文档见(问题17)允许选择文件夹目录.xls。UploadFiles/2006-8/83574180.rar 此外,运行下面的代码将允许用户使用Windows对话框选择一个文件: ‘*********************************** Sub test() Dim Filename Filename = Application.GetOpenFilename() End Sub ‘*********************************** GetOpenFilename是一个内置的Excel函数,它仅返回一个文件名。您必须采取读取文件的操作。 =================================================================== 问题18:如何查找应用工作表公式后出现错误的单元格? 解答:下面是一个很方便使用的程序,用于查找在工作表中应用公式后出现错误值的单元格并选中。 ‘*********************************** Sub FindErrors() ‘如果没有在工作表中发现错误,将会产生错误 On Error Goto FEError ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas, xlErrors).Select Exit Sub FEError: MsgBox "没有发现错误", , "提示!" Exit Sub End Sub ‘*********************************** =================================================================== 问题19:如何查找工作表中的最后一行? 解答:下面是一个快速且简单的函数,用于获取工作表中含有数据的最后一行。 ‘*********************************** Function GetLastRow(SheetID) As Integer Dim LastRow As Integer If Application.WorksheetFunction.CountA(Worksheets(SheetID).Cells) = 0 Then LastRow = 1 Else LastRow = Worksheets(SheetID).UsedRange.Rows.Count + Worksheets(SheetID).UsedRange.Row While Application.WorksheetFunction.CountA(Worksheets(SheetID).Rows(LastRow)) = 0 LastRow = LastRow - 1 Wend End If GetLastRow = LastRow End Function ‘*********************************** 您可以使用简单的语句进行测试,在代码模块中输入如下代码: ‘*********************************** Sub test() Dim I As Long I=GetLastRow(1) Debug.Print i End Sub ‘*********************************** 运行上述过程后,将会在立即窗口中显示当前工作簿中工作表1中最后一行的行号。 =================================================================== 问题20:如何定位某个特定的单元格为屏幕左上角的单元格? 解答:可以通过滚动行和滚动列来实现: ‘*********************************** '定位工作表中的单元格M14在屏幕左上角 Sub test() Worksheets(1).Select ActiveWindow.ScrollRow = 14 ActiveWindow.ScrollColumn = 13 End Sub ‘*********************************** 也可以使用以下语句实现: ‘*********************************** '定位工作表中的单元格G10在屏幕左上角 Sub test() Application.GoTo Range("G10"), True End Sub =================================================================== 问题21:如何添加自定义工具条? 解答:下面是添加自定义工具条的示例代码,运行该代码后将在“标准”工具条的右侧出现一个名为“我的工具条”的自定义工具条,与Excel的内置工具条一样,您可以移动/悬浮它,并且单击工具条里的命令可以执行相应的操作。当然,如果您愿意的话,可以将本示例扩展,添加一些有用的命令在自定义的工具条上,从而扩展Excel的功能。 本示例中,该工具条是临时的,当您关闭工作簿后,它不会保存。您最好在在Workbook_Open事件中调用”AddToolbar”程序,这样当打开该工作簿时,自动添加自定义的工具条。 ‘*********************************** Sub AddToolBar() Dim cmdbar As CommandBar Dim CmdBtn1 As CommandBarButton Dim strTBName As String strTBName = "我的工具条" '如该工具条已经存在则不再添加 If CheckForToolbar(strTBName) Then Exit Sub Set cmdbar = CommandBars.Add(Name:=strTBName, Position:=msoBarTop, Temporary:=True) cmdbar.Visible = True With cmdbar '放置该工具条在“标准”工具条的右侧 .Left = CommandBars("Standard").Width .RowIndex = CommandBars("Standard").RowIndex Set CmdBtn1 = .Controls.Add(msoControlButton, , , , True) With CmdBtn1 .Style = msoButtonCaption .Caption = "我的工具条" .TooltipText = "这是一个示例工具条." .OnAction = "HelloWorld" End With End With Set cmdbar = Nothing Set CmdBtn1 = Nothing End Sub ‘*********************************** Function CheckForToolbar(argName As String) As Boolean Dim bar As CommandBar, Result As Boolean Result = False For Each bar In CommandBars If bar.Name = argName Then Result = True End If Next bar CheckForToolbar = Result End Function ‘*********************************** Sub HelloWorld() MsgBox "Hello World!" End Sub ‘*********************************** 示例文档见(问题21)添加工具条示例.xls。UploadFiles/2006-8/83436686.rar =================================================================== 问题22:在执行Application.Quit命令后,如何避免出现保存警告信息框? 解答:通常当执行Application.Quit语句后,如果在这之前工作簿有变化,都会出现“是否保存对工作簿XXX的修改”的警告框。为了避免出现这个警告框,可以采用以下方法。 1、添加代码指定您是否想保存工作簿所发生的变化,代码如下: ‘*********************************** Workbooks(x).Close Savechanges:=True ‘*********************************** 运行上述代码后,将弹出“另存为”对话框。 2、关闭Excel警告信息。这样对工作簿所做的任何改变均不会被保存,等于在警告框中选择“否”按钮。因此,这种方法将会使您对工作簿所做的更改不被保存,建议您在需要避免警告框的地方使用该语句后,立即恢复设置。即: ‘*********************************** Application.DisplayAlerts = False Workbooks(x).Close Application.DisplayAlerts = True ‘*********************************** 3、使用语句,让Excel觉得工作簿已经被保存过了。 ‘*********************************** Workbooks(x).Saved = True Workbooks(x).Close ‘*********************************** =================================================================== 问题23:如何确定单元格背景颜色的名称或者索引号? 解答:下面的自定义函数可用来返回单元格背景颜色索引号或者是颜色名称。 ‘*********************************** Function CellColor(rCell As Range, Optional ColorName As Boolean) Dim strColor As String, iIndexNum As Integer Select Case rCell.Interior.ColorIndex Case 1 strColor = "Black" iIndexNum = 1 Case 53 strColor = "Brown" iIndexNum = 53 Case 52 strColor = "Olive Green" iIndexNum = 52 Case 51 strColor = "Dark Green" iIndexNum = 51 Case 49 strColor = "Dark Teal" iIndexNum = 49 Case 11 strColor = "Dark Blue" iIndexNum = 11 Case 55 strColor = "Indigo" iIndexNum = 55 Case 56 strColor = "Gray-80%" iIndexNum = 56 Case 9 strColor = "Dark Red" iIndexNum = 9 Case 46 strColor = "Orange" iIndexNum = 46 Case 12 strColor = "Dark Yellow" iIndexNum = 12 Case 10 strColor = "Green" iIndexNum = 10 Case 14 strColor = "Teal" iIndexNum = 14 Case 5 strColor = "Blue" iIndexNum = 5 Case 47 strColor = "Blue-Gray" iIndexNum = 47 Case 16 strColor = "Gray-50%" iIndexNum = 16 Case 3 strColor = "Red" iIndexNum = 3 Case 45 strColor = "Light Orange" iIndexNum = 45 Case 43 strColor = "Lime" iIndexNum = 43 Case 50 strColor = "Sea Green" iIndexNum = 50 Case 42 strColor = "Aqua" iIndexNum = 42 Case 41 strColor = "Light Blue" iIndexNum = 41 Case 13 strColor = "Violet" iIndexNum = 13 Case 48 strColor = "Gray-40%" iIndexNum = 48 Case 7 strColor = "Pink" iIndexNum = 7 Case 44 strColor = "Gold" iIndexNum = 44 Case 6 strColor = "Yellow" iIndexNum = 6 Case 4 strColor = "Bright Green" iIndexNum = 4 Case 8 strColor = "Turqoise" iIndexNum = 8 Case 33 strColor = "Sky Blue" iIndexNum = 33 Case 54 strColor = "Plum" iIndexNum = 54 Case 15 strColor = "Gray-25%" iIndexNum = 15 Case 38 strColor = "Rose" iIndexNum = 38 Case 40 strColor = "Tan" iIndexNum = 40 Case 36 strColor = "Light Yellow" iIndexNum = 36 Case 35 strColor = "Light Green" iIndexNum = 35 Case 34 strColor = "Light Turqoise" iIndexNum = 34 Case 37 strColor = "Pale Blue" iIndexNum = 37 Case 39 strColor = "Lavendar" iIndexNum = 39 Case 2 strColor = "White" iIndexNum = 2 Case Else strColor = "自定义的颜色或者没有填充颜色." End Select If ColorName = True Or _ strColor = "自定义的颜色或者没有填充颜色." Then CellColor = strColor Else CellColor = iIndexNum End If End Function ‘*********************************** 当您在VBE编程器中的标准模块代码窗口中输入上述代码并保存后,该函数将出现在“用户定义”函数列表中,您可以在工作簿中进行测试。例如,如果您将工作表中A1单元格背景色设置为绿色,在A2单元格中输入公式“=CellColor(A1,True)”后,将显示文本“Green”;若输入公式“=CellColor(A1,False)或=CellColor(A1)”,则显示索引号“10”。即该函数的第二个参数设置为“True”,则显示颜色文本;若设置为“False”或省略,则显示颜色索引号。 示例文档见(问题23)确定单元格背景颜色.xls。UploadFiles/2006-8/83922501.rar =================================================================== 问题24:如何查找两个值之间的值? 解答:在Excel和大多数的MS Office应用程序中,有一个“查找”功能可用来在一个范围、工作表或工作簿中查找特定的值、或者文本字符串。然而,没有一个用于查找在两个值之间(指定的最大值和最小值)之间第一次出现某个值的位置的功能,我们能使用VBA代码来处理。代码如下: ‘*********************************** Sub GetBetween() Dim strNum As String Dim lMin As Long, lMax As Long Dim rFound As Range, rLookin As Range Dim lFound As Long, rStart As Range Dim rCcells As Range, rFcells As Range Dim lCellCount As Long, lcount As Long Dim bNoFind As Boolean strNum = InputBox("请先输入最大值,然后输入逗号," _ & "接着输入最大值" & vbNewLine & _ vbNewLine & "例如: 1,10", "输入最小值和最大值") If strNum = vbNullString Then Exit Sub On Error Resume Next lMin = Left(strNum, InStr(1, strNum, ",")) If Not IsNumeric(lMin) Or lMin = 0 Then MsgBox "输入数据错误, 或者最小值不应为零", vbCritical Exit Sub End If lMax = Replace(strNum, lMin & ",", "") If Not IsNumeric(lMax) Or lMax = 0 Then MsgBox "输入数据错误,或者最大值不应为零", vbCritical Exit Sub End If If lMax < lMin Then MsgBox "最小值大于最大值", vbCritical Exit Sub End If If lMin + 1 = lMax Then MsgBox "最大值和最小值之间没有范围", vbCritical Exit Sub End If If Selection.Cells.Count = 1 Then Set rCcells = Cells.SpecialCells(xlCellTypeConstants, xlNumbers) Set rFcells = Cells.SpecialCells(xlCellTypeFormulas, xlNumbers) Set rStart = Cells(1, 1) Else Set rCcells = Selection.SpecialCells(xlCellTypeConstants, xlNumbers) Set rFcells = Selection.SpecialCells(xlCellTypeFormulas, xlNumbers) Set rStart = Selection.Cells(1, 1) End If '缩小查找范围 If rCcells Is Nothing And rFcells Is Nothing Then MsgBox "工作表无数据", vbCritical Exit Sub ElseIf rCcells Is Nothing Then Set rLookin = rFcells.Cells '公式 ElseIf rFcells Is Nothing Then Set rLookin = rCcells.Cells '常量 Else Set rLookin = Application.Union(rFcells, rCcells) '公式和常量 End If lCellCount = rLookin.Cells.Count Do Until lFound > lMin And lFound < lMax And lFound > 0 lFound = 0 Set rStart = rLookin.Cells.Find(What:="*", After:=rStart, LookIn:=xlValues, _ LookAt:=xlWhole, SearchOrder:=xlByRows, _ SearchDirection:=xlNext, MatchCase:=True) lFound = rStart.Value lcount = lcount + 1 If lCellCount = lcount Then bNoFind = True Exit Do End If Loop rStart.Select If bNoFind = True Then MsgBox "没有数据在" _ & lMin & " 和 " & lMax & "之间", vbInformation End If On Error GoTo 0 End Sub ‘*********************************** 该代码将以工作表中“查找”功能相同的方式工作,当仅选择一个单元格时,将在所有单元格中查找;当选择一部分单元格时,仅在所选单元格区域中查找,在两个值之间的符合条件的第一个单元格被选中,不包含最小值和最大值本身。注意,本程序代码不会查找零值。 例如,在工作表中有1至10共10个数据,若您要查找3至5之间的数据,运行后在对话框中输入3,5,内容为4的单元格将被选中。 示例文档见(问题24)查找最大最小值之间的值.xls。UploadFiles/2006-8/83406803.rar =================================================================== 问题25:如何在一个单元格区域获取两个给定数值之间的最大值? 解答:下面的自定义函数将在单元格区域中获取任意两个指定数值之间的最大值。 ‘*********************************** Function GetMaxBetween(rCells As Range, MinNum, MaxNum) Dim rRange As Range Dim vMax Dim aryNums() Dim i As Integer ReDim aryNums(rCells.Count) For Each rRange In rCells vMax = rRange Select Case vMax Case MinNum + 0.01 To MaxNum - 0.01 aryNums(i) = vMax i = i + 1 Case Else GetMaxBetween = 0 End Select Next rRange GetMaxBetween = WorksheetFunction.Max(aryNums) End Function ‘*********************************** 您在VBE编辑器中输入上述代码后,该函数将出现在“用户定义”函数中,您可以在工作表单元格中输入公式进行测试,例如,在单元格C7中输入“=GetMaxBetween(A1:A10,2,9)”回车后将得到单元格区域A1至A10中大于2且小于9的最大值,精度可达到0.01,本例中为8。 示例文档见(问题25)获取两个数值之间的最大值.xls。UploadFiles/2006-8/83769901.rar |