VBA массив уникальных значений не собирает определенные числа

Question

Я написал некоторый код, который сканирует список чисел и сохраняет уникальные значения в массиве.Числа варьируются от 1 до 12 (они представляют месяцы и упорядочены последовательно) и выглядят так:

A |10 10 10 11 11 12 12 12 12 1 1 1 2 2 3 3 4 4 4 5 5 и т. Д.

Цифры указаны в столбце I, от ряда 2 до последнего ряда каждого листа.Проблема, с которой я сталкиваюсь, заключается в том, что числа 1 и 2 не хранятся в массиве.Когда приведенный ниже код выполняется в моей электронной таблице, массив сохраняется как:

10 |11 |12 |3 |4 |5 и т. Д. (Если есть больше месяцев)

Я не уверен, почему это происходит - я подозреваю, что это потому, что месяц, предшествующий 1 и 2, равен 12, который содержит цифры 1 и 2. Однако,Я не уверен, почему код пропустил бы это, или как это исправить.Буду признателен за любую помощь или совет.

Dim i as integer
Dim tmp as string, msg as string, arr as string
Dim ws as worksheet
Dim lastrow as long

Set ws = ActiveSheet
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row

    For Each cell In ws.Range("I2:I" & lastrow)
        If (cell <> "") And (InStr(tmp, cell) = 0) Then
            tmp = tmp & cell & "|"
        End If
    Next cell

If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
    arr = Split(tmp, "|")
        For i = LBound(arr) To UBound(arr)
            msg = msg & arr(i) & vbNewLine
        Next i

Answer 1

Или так, если вы хотите использовать массив, а не объект словаря ...

Option Explicit

Public Sub Process()

    Dim i As Long
    Dim msg As String
    Dim arr() As String
    Dim ws As Worksheet
    Dim lastrow As Long
    Dim cell As Variant
    Dim FoundAt As Long

    Set ws = ActiveSheet
    lastrow = ws.Cells(1048576, "I").End(xlUp).Row

    For Each cell In ws.Range("I2:I" & lastrow)
        If (cell <> "") Then

            FoundAt = -1
            If Len(Join(arr)) > 0 Then
                For i = LBound(arr) To UBound(arr)
                    If arr(i) = cell Then FoundAt = i
                Next
            End If

            If FoundAt = -1 Then
                If Len(Join(arr)) > 0 Then
                    ReDim Preserve arr(UBound(arr) + 1)
                Else
                    ReDim arr(1)
                End If
                arr(UBound(arr)) = cell
            End If

        End If
    Next cell

    For i = LBound(arr) To UBound(arr)
        msg = msg & arr(i) + vbCrLf
    Next

    MsgBox msg

End Sub

Answer 2

Я предполагаю, что ваша проблема (как упомянуто в комментариях ), потому что вы создаете строку, которая выглядит следующим образом:

10 | 11 | 12

, но при тестировании строки выиспользуют:

InStr(tmp, cell) = 0

Если cell содержит 1, то InStr(tmp, cell) не вернет 0, поскольку 1 уже находится во встроенной строке (как часть10, 11 или 12).

Это можно исправить, создав строку следующим образом:

|10|11|12|

и затем проверив:

InStr(tmp, "|" & cell & "|") = 0

InStr будет соответствовать значению ячейки только в том случае, если оно окружено символами канала (|).

---

Однако я думаю, что гораздо более простым решением было бы использование Scripting.Dictionary чтобы создать список уникальных чисел:

Dim ws As Worksheet
Dim lastrow As Long
Dim cell As Variant

' Add a reference (Tools -> References...) to Microsoft Scripting Runtime
Dim dict as New Scripting.Dictionary

Set ws = ActiveSheet
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row

For Each cell In ws.Range("I2:I" & lastrow)
    If cell.Value <> "" Then
        dict(cell.Value) = 1 ' dummy value; we're only interested in the dictionary keys
    End If
Next cell

, а затем использовать функцию Join вместе с коллекцией словаря Keys для построения строки значений с разделителями:

Dim msg As String
msg = Join(dict.Keys, vbNewLine)

Это работает, потому что словарь содержит только одну запись ключ / значение для данного ключа.

Answer 3

Попробуйте это.

Sub test()
    Dim i As Integer
    Dim tmp As String, msg As String, arr As Variant
    Dim ws As Worksheet
    Dim lastrow As Long
    Dim dic As Object
    Dim s As String
    Set ws = ActiveSheet

    Set dic = CreateObject("Scripting.Dictionary")

    Set ws = ActiveSheet
    lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row

        For Each cell In ws.Range("I2:I" & lastrow)
            'If (cell <> "") And (InStr(tmp, cell) = 0) Then
            If cell <> "" Then
                s = CStr(cell)
                If dic.Exists(s) Then
                Else
                    dic.Add s, s
                    tmp = tmp & cell & "|"
                End If
            End If
        Next cell

    If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
        arr = Split(tmp, "|")
            For i = LBound(arr) To UBound(arr)
                msg = msg & arr(i) & vbNewLine
            Next i


End Sub