Question

我有一列包含唯一字符串的数据，其中字符串中的前4个字符可能是另一个字符串中前4个字符的重复，格式类似于：

ABCDEF  
ABCDXY 
ABCDKL
DTYTZF 
DTYTSD

我试图循环显示这些数据，以确定哪4个起始字符出现的次数超过3次。如果字符串的前4位数出现3次或更多次，我想完全从数组中删除它们，最后得到一个排除这些值的数组。例如，在上面的专栏中，由于3个字符串或更多字符串以'ABCD'开头，我想删除所有以此代码开头的字符串，并且只保留其他所有值，这样我的结果将是：

DTYTZF 
DTYTSD

我正在循环遍历数组，将任何三次或更多次出现的值推送到一个NEW数组中，然后计划使用该列表对原始数组进行第二次传递，并删除所有匹配项。这可能不是最有效的方法，但我无法确定一种更好的方法，保证不会弄乱我的数据。

我已经通过遍历字符串来确定哪些字符串出现的次数超过了一次，但是当我尝试将它们推送到数组时，字符串成功被推送到数组，但是很快就被替换为下一个值因为它被推送到阵列。我知道值被正确推送，因为如果我之后立即查看数组，我会看到数组中的值。当按下下一个值并再次查看该数组时，仅显示 new 值（较旧的值不显示）。

我认为这是由于我对ReDiming数组的理解有限，而且我还没有完全理解将该值推入数组的代码片段。我的（精简）代码如下：

Sub pickupValues()
    Dim valuesArray()
    Dim i As Long
    Dim y As Long
    Dim sizeCheck As Long
    Dim tempArray() As String

    valuesArray() = Worksheets("Sheet1").Range("A1:A10").Value

    For i = LBound(valuesArray) To UBound(valuesArray)
        sizeCheck = 0
        For y = LBound(valuesArray) To UBound(valuesArray)
            If Left(valuesArray(i, 1), 4) = Left(valuesArray(y, 1), 4) Then
                sizeCheck = sizeCheck + 1
                i = y
                If sizeCheck >= 3 Then
                    ReDim tempArray(1 To 1) As String 'I'm not sure why I need to do this. 
                    tempArray(UBound(tempArray)) = Left(valuesArray(i, 1), 4) 'I believe this is what pushes the value into the array. 
                    ReDim Preserve tempArray(1 To UBound(tempArray) + 1) As String 'Again unsure on what the purpose of this is. 
                    viewArray (tempArray) 
                End If
            End If
        Next y
    Next i

End Sub


Function viewArray(myArray)
    Dim txt As String
    Dim i As Long

    For i = LBound(myArray) To UBound(myArray)
    txt = txt + myArray(i) + vbCrLf
    Next i

    MsgBox txt
End Function

我做错了什么？

我想在函数中稍后重新使用相同的基本代码，根据它们是否与字符串匹配来推送数组的其他值OUT，但似乎VBA不喜欢将值移出数组。是否有一个符合两种情况的简单解决方案？

Answer 1

我改写了你要做的事。我正在使用filter函数快速获取数组中的结果

Option Explicit
Public Sub pickupValues()
    Dim tmp As Variant
    Dim results As Variant
    Dim i As Long
    Dim v

    ' Make sure this matches your range
    With ThisWorkbook.Sheets("Sheet1")
        ' Important to transpose the input here as Filter will only take a 1D array. Even though it's only 1 column, setting an array this way will generate a 2D array
        tmp = Application.Transpose(.Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)).Value2)
    End With

    ' ReDiming to the maximum value and slimming down afterwards is much quicker then increasing your array each time you've found a new value
    ReDim results(1 To UBound(tmp))
    For Each v In tmp
        ' Less then 2 as first result is '0'. Will return '-1' if can't be found but as test criteria is in the array it will always be at least 0
        If UBound(Filter(tmp, Left(v, 4))) < 2 Then
            i = i + 1
            results(i) = v
        End If
    Next v
    ' Redim Preserve down to actual array size
    If i > 0 Then
        ReDim Preserve results(1 To i)
        viewArray (results)
    Else
        MsgBox "Nothing Found"
    End If
End Sub
' Should really be a sub as doesn't return anything back to caller
Public Sub viewArray(myArray)
    MsgBox Join(myArray, vbCrLf)
End Sub

Answer 2

您的算法无法帮助您。

选项1：对数组进行排序。然后，您可以进行一次传递，以查找具有相同前四个字符的连续值并计算它们。

选项2：使用Dictionary对象：前四个字符作为键，出现次数为值。

VBA将值插入数组替换值而不是插入

2 个答案: