ReDim保留2D超出范围

Question

此函数获取两个参数范围和一个值以匹配内部范围，然后返回具有匹配值及其地址的数组。但是它给出了ReDim Preserve的错误，并且当数组为空（不匹配任何值）时它会给出错误

Function filter_range_value(rng As String, selected_value As String) As Variant 
    Dim cell As Range
    Dim array_storage() As Variant
    Dim element As Integer

    element = 1

    For Each cell In Range(rng)
        If InStr(cell, selected_value) > 0 Then
            ReDim Preserve array_storage(element, 1)
            array_storage(element, 0) = cell
            array_storage(element, 1) = cell.address
            element = element + 1
        End If
    Next cell

    filter_range_value = array_storage
End Function

Answer 1

解决问题：

您无法使用Redim Preserve更改2D数组中的第一个维度。

使用COUNTIF（）查找所需的正确行数。

element = Application.WorksheetFunction.CountIf(rng, "*" & selected_value & "*")
ReDim array_storage(1 To element, 1 To 2)

其他说明：

我还将rng更改为Range而不是String，因此我们无需强制vba进行解析。

=filter_range_value(A:A,"a")

行Set rng = Intersect(rng, rng.Parent.UsedRange)只是确保我们没有进行任何不必要的迭代。这将允许rng的完整列引用，它只会迭代使用范围内的那些。

目前，您可以查找特定于案例的字符串。如果您想使其不是特定于案例的使用：

    If InStr(1, cell, selected_value, vbTextCompare) > 0 Then

defualt是vbBinaryCompare，具体情况。

Function filter_range_value(rng As Range, selected_value As String) As Variant
Dim cell As Range
Dim array_storage() As Variant
Dim element As Long
Set rng = Intersect(rng, rng.Parent.UsedRange)
element = Application.WorksheetFunction.CountIf(rng, "*" & selected_value & "*")
ReDim array_storage(1 To element, 1 To 2)
element = 1
For Each cell In rng
    If InStr(1, cell, selected_value, vbTextCompare) > 0 Then
        array_storage(element, 1) = cell
        array_storage(element, 2) = cell.Address
        element = element + 1
    End If
Next cell
filter_range_value = array_storage
End Function

Answer 2

我建议您使用VBA.Collection或Scripting.Dictionary吗？这比使用数组更容易使用，您无需担心在运行时分配正确的大小。收集/字典的关键字可以是范围地址。