CODEWITHSUNDEEP
excelvba
sashkello
sashkello

Reputation: 17871

checking if value present in array

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

Basically, this script is going through a column selecting distinct values and populating array arr with them. First If is 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 cell string. If it is not present, I want to add it.

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 IsInArray function. Can someone let me know where I went wrong?

Upvotes: 4

Views: 41405

Answers (3)

mak
mak

Reputation: 1404

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

Upvotes: 0

Beallio
Beallio

Reputation: 61

Short answer to your "Subscript out of range" error on the call of IsInArray function" question is that the variable arr is dimmed as Variant. For the Filter function to work in the IsInArray UDF arr must be dimmed as a String.

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

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

Upvotes: 1

David Zemens
David Zemens

Reputation: 53623

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

I have consolidated some of your If/ElseIf logic with a Do...While loop, and then use the Match function 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.

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

Upvotes: 4

Related Questions