4

我正在使用this question中的一个函数，但是，它似乎不适用于我的情况。

基本上，这个脚本正在通过一列选择不同的值并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

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

4

3 回答 3

4

这是我将如何使用该Application.Match函数而不是另一个 UDF 来处理一维数组的方法。

我已将您的一些 If/ElseIf 逻辑与Do...While循环合并，然后使用该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
于 2013-04-16T02:16:58.163 回答
1

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

您可以尝试以下代码，其中 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
于 2013-04-19T08:52:34.463 回答
0

这是一个简单但肮脏的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
于 2016-11-02T01:00:47.973 回答