VBA编程问答

最新推荐文章于 2021-10-28 22:54:02 发布

ZOU_SEAFARER

最新推荐文章于 2021-10-28 22:54:02 发布

阅读量2.2k

点赞数

分类专栏： VBA 文章标签： vba 编程 integer function 工作 string

VBA 专栏收录该内容

67 篇文章 21 订阅

订阅专栏

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