|
|
楼主 |
发表于 2010-8-16 16:43
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
问题24：如何查找两个值之间的值？
解答：在Excel和大多数的MSOffice应用程序中，有一个“查找”功能可用来在一个范围、工作表或工作簿中查找特定的值、或者文本字符串。然而，没有一个用于查找在两个值之间(指定的最大值和最小值)之间第一次出现某个值的位置的功能，我们能使用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的单元格将被选中。
===================================================================
问题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.
===================================================================
问题26：如何实现单元格在指定区域内自动跳转?
例如，在单元格区域A1：C100中，无论何时在其中的某个单元格中输入完一个单个的字符后，自动按规律跳转到下一单元格，即在单元格B1中输完后，跳转到单元格C1，在单元格C1中输入完单个字符后，自动跳转到单元格A2，……
解答：可以在工作表事件中使用下面的代码：
‘***********************************
PrivateSub Worksheet_Change(ByVal Target As Range)
ConstWS_RANGE As String = "A1:C100" '<==按需要改变单元格区域
On ErrorGoTo ws_exit
Application.EnableEvents = False
If NotIntersect(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列。
不限于列的代码如下：
‘***********************************
PrivateSub Worksheet_Change(ByVal Target As Range)
Dim Rng AsRange
Dim Ix AsLong, Ad As String
Set Rng =Range("F4:G50") '<==按需要改变单元格区域
On ErrorGoTo ws_exit
Application.EnableEvents = False
If NotIntersect(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列。
===================================================================== |
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2010-8-16 16:37
