vba 检查数组中是否存在值

checking if value present in array

提问by sashkello

I'm using a function from thisquestion, however, it doesn't seem to work in my case.

我正在使用这个问题中的一个函数，但是，在我的情况下它似乎不起作用。

Basically, this script is going through a column selecting distinct values and populating array arrwith them. First Ifis checking if the column has ended, then to avoid calling empty array I have the first IfElse, and finally I want to check a non-empty array for cellstring. If it is not present, I want to add it.

基本上，这个脚本通过一列选择不同的值并arr用它们填充数组。首先If是检查列是否已经结束，然后为了避免调用空数组，我有第一个IfElse，最后我想检查一个非空数组的cell字符串。如果它不存在，我想添加它。

Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
  IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

Sub SelectDistinct()

    Dim arr() As String
    Dim i As Integer
    Dim cells As Range

    Set cells = Worksheets("types").Columns("A").Cells

    i = 0
    For Each cell In cells
        If IsEmpty(cell) Then
            Exit For
        ElseIf i = 0 Then
            ReDim Preserve arr(i)
            arr(UBound(arr)) = cell
            i = i + 1
        ElseIf IsInArray(cell.Value, arr) = False Then
            ReDim Preserve arr(i)
            arr(UBound(arr)) = cell
            i = i + 1
        End If
    Next cell
End Sub

For some reason, it throws "Subscript out of range" error on the call of IsInArrayfunction. Can someone let me know where I went wrong?

出于某种原因，它在调用IsInArray函数时抛出“下标超出范围”错误。有人可以让我知道我哪里出错了吗？

采纳答案by David Zemens

Here is how I would do it for a one-dimensional array, using the Application.Matchfunction, instead of another UDF.

这是我将如何使用该Application.Match函数而不是另一个 UDF对一维数组执行此操作。

I have consolidated some of your If/ElseIf logic with a Do...Whileloop, and then use the Matchfunction to check whether cell value exists in the array. If it does not exist, then add it to the array and continue to the next cell in your range.

我已经用Do...While循环合并了您的一些 If/ElseIf 逻辑，然后使用该Match函数检查数组中是否存在单元格值。如果它不存在，则将其添加到数组中并继续到您范围内的下一个单元格。

Sub SelectDistinct()

Dim arr() As String
Dim i As Integer
Dim cells As Range
Dim cl As Range
Dim foundCl As Boolean

    Set cells = Worksheets("Sheet6").Columns(1).cells

    Set cl = cells.cells(1)

    Do
        If IsError(Application.Match(cl.Value, arr, False)) Then
            ReDim Preserve arr(i)
            arr(i) = cl
            i = i + 1
        Else:
            'Comment out the next line to completely ignore duplicates'
            MsgBox cl.Value & " already exists!"

        End If

        Set cl = cl.Offset(1, 0)
    Loop While Not IsEmpty(cl.Value)

End Sub

回答by Beallio

Short answer to your "Subscript out of range" error on the call of IsInArrayfunction" question is that the variable arris dimmed as Variant. For the Filterfunction to work in the IsInArrayUDF arrmust be dimmed as a String.

对“IsInArray函数调用时下标超出范围”错误的简短回答是变量arr变暗为Variant。要Filter在IsInArrayUDF 中工作的函数arr必须变暗为String。

You can try the following code which 1) Sets up a filtered Stringarray, and 2) avoids placing Redim Preserve(which is a costly function) in a loop:

您可以尝试以下代码，其中 1) 设置过滤String数组，以及 2) 避免将Redim Preserve（这是一个代价高昂的函数）放入循环中：

Sub FilteredValuesInArray()
'http://stackoverflow.com/questions/16027095/checking-if-value-present-in-array
Dim rng As Range
Dim arrOriginal() As Variant, arrFilteredValues() As String
Dim arrTemp() As String
Dim strPrintMsg As String    'For debugging
Dim i As Long, lCounter As Long

Set rng = Cells(1, 1).CurrentRegion    'You can adjust this how you want
arrOriginal = rng

'Convert variant array to string array
ReDim arrTemp(LBound(arrOriginal) - 1 To UBound(arrOriginal) - 1)
For i = LBound(arrOriginal) To UBound(arrOriginal)
    arrTemp(i - 1) = CStr(arrOriginal(i, 1))
Next i

'Setup filtered values array
ReDim arrFilteredValues(LBound(arrTemp) To UBound(arrTemp))

On Error Resume Next
Do
    arrFilteredValues(lCounter) = arrTemp(0)
    'Save non matching values to temporary array
    arrTemp = Filter(arrTemp, arrTemp(0), False)
    'If error all unique values found; exit loop
    If Err.Number <> 0 Then Exit Do
    lCounter = lCounter + 1
Loop Until lCounter >= UBound(arrFilteredValues)
On Error GoTo 0
'Resize array to proper bounds
ReDim Preserve arrFilteredValues(LBound(arrFilteredValues) To lCounter - 1)

'====DEBUG CODE
For i = LBound(arrFilteredValues) To UBound(arrFilteredValues)
    strPrintMsg = strPrintMsg & arrFilteredValues(i) & vbCrLf
Next i
Debug.Print vbTab & "Filtered values are:" & vbCrLf & strPrintMsg
'====END DEBUG CODE
End Sub

回答by mak

Here's an easy yet dirty hack :

这是一个简单而肮脏的黑客：

Function InStringArray(str As String, a As Variant) As Boolean
    Dim flattened_a As String
    flattened_a = ""

    For Each s In a
        flattened_a = flattened_a & "-" & s
    Next

    If InStr(flattened_a, str) > 0 Then
        InStringArray = True
    Else
        InStringArray = False
    End If
End Function