Question

是否有一种简单的方法，不是循环遍历数组，而是在VBA中使用函数，比如Application.Match（val，arr，False | true），以查找浮点数组中元素的索引，在一些容忍范围内？在公差范围内，我的意思是，如果元素在目标值的范围内加上和减去公差，即小的正数。

Trimax评论说这是another index return question的副本。事实并非如此，即使这两个问题是相关的，这个问题的答案肯定不能回答我的问题。那个问题要求一个整数的索引可以精确匹配，而我要求一个数字的索引在一个目标的非零容忍范围内，而不是完全相等。所以答案不适用。

Answer 1

作为练习，我选择了一组随机浮动数字：

3.5, 3.1, 3.3, 3.9, 3.2, 3.1, 3.7, 3.5, 3.7

和任意MIN（3.3）和MAX（3.7）限制。

我还使用AutoFilter替换条件格式以获得相同的结果

代码将创建一个新工作表

将数组值放在第1列
使用索引（行号）
应用自动筛选仅显示MIN和MAX之间的浮点数
从第2列捕获所有可见索引
删除临时表并显示消息

Option Explicit

'Place the code in a new module (from the menu: Insert -> Module)

Public Sub getIndexes()

    Const MIN       As String = "3.3"
    Const MAX       As String = "3.7"
    Const FLOATS    As String = "3.5, 3.1, 3.3, 3.9, 3.2, 3.1, 3.7, 3.5, 3.7"

    Dim ws As Worksheet, arr As Variant, arrMax As Long
    Dim indx As Variant, c1 As Range, c2 As Range

    Application.ScreenUpdating = False
    Set ws = getNewWorkSheet("TestIndexes")
    arr = Split(FLOATS, ", ")
    arrMax = UBound(arr) + 1
    With ws
        Set c1 = .Range(.Cells(1, 1), .Cells(arrMax, 1))
        Set c2 = .Range(.Cells(1, 2), .Cells(arrMax, 2))
        c1 = Application.Transpose(arr)
        c2.Formula = "=ROW()"
        c1.AutoFilter Field:=1, _
                      Criteria1:=">=" & MIN, _
                      Operator:=xlAnd, _
                      Criteria2:="<=" & MAX
        c2.SpecialCells(xlCellTypeVisible).Copy .Cells(arrMax + 2, 1)
        indx = .Range(.Cells(arrMax + 2, 1), .Cells(.UsedRange.Rows.Count, 1)).Value2
    End With
    removeWorkSheet ws.Name
    Application.ScreenUpdating = True

    arr = Join(Application.Transpose(indx), ",   ")
    MsgBox "Indexes of values between  " & MIN & "  and  " & MAX & ":   " & arr
End Sub

Public Function getNewWorkSheet(ByVal wsName As String) As Worksheet
    Dim thisWS As Worksheet, activeWS As String
    activeWS = ActiveSheet.Name
    removeWorkSheet wsName
    Set thisWS = Worksheets.Add(Sheets(1))
    thisWS.Name = wsName
    Worksheets(activeWS).Activate
    Set getNewWorkSheet = thisWS
End Function

Public Sub removeWorkSheet(ByVal wsName As String)
    Dim thisWS As Worksheet
    For Each thisWS In ActiveWorkbook.Worksheets
        If thisWS.Name = wsName Then
            Application.DisplayAlerts = False
            thisWS.Delete
            Application.DisplayAlerts = True
            Exit For
        End If
    Next
End Sub

结果：

random array output

如果您正在使用大型数组，则可以针对性能优化算法

如果您需要更多详细信息，请与我们联系

返回VBA中容错内数组元素的索引

1 个答案: