значения ячейки памяти vba отбирают числовые данные

Question

У меня проблема. Я пытаюсь скопировать все уникальные значения (числовые и буквенно-цифровые) с динамического листа на другой. Я нашел отличный сценарий на форуме, который работает быстро и адаптировал его. Проблема в том, что, кажется, отфильтровывает все числовые значения и жизнь меня, я не понимаю, почему!?! Вы можете помочь?

Sub GetUniqueItems() 
    Dim vData As Variant, n&, lLastRow&, sMsg$ 

    lLastRow = Worksheets(Worksheets("Summary").Range("A1").Value)._ 
    Cells(Rows.Count, "H").End(xlUp).Row 
    If lLastRow = 1 Then Exit Sub '//no data 

    vData = Worksheets(Worksheets("Summary").Range("A1").Value)._ 
    Range("H2:H" & lLastRow) 
    Dim oColl As New Collection 
    On Error Resume Next 
    For n = LBound(vData) To UBound(vData) 
    oColl.Add vData(n, 1), vData(n, 1) 
    Next 'n 

    For n = 1 To oColl.Count 
    sMsg = oColl(n) 
    Sheets("Summary").Cells(n + 3, 1).Value = Mid$(sMsg, 1) 
    Next 'n 

    End Sub 

Answer 1

Ключ для предмета Collection должен быть строкой. Так измените эту строку:

oColl.Add vData(n, 1), vData(n, 1) 

к этому:

oColl.Add vData(n, 1), CStr(vData(n, 1)) 

Кроме того, хотя вам нужно On Error Resume Next так что код будет skip over любые попытки добавить дубликаты в коллекции, вы должны использовать его только для того одна линия. В противном случае вы рискуете замаскировать другие ошибки в вашем коде. (Причина ваш код не было ошибки во время выполнения потому, что в On Error Resume Next, в дополнение к выполнению его работу в обход дубликатов, также пропускал через любой Adds с числовым Keys.

По этой причине я переместил линию как раз перед oColl.Add и добавил On Error Goto 0 только после того, как:

Вот полная процедура:

Sub GetUniqueItems() 
Dim vData As Variant, n&, lLastRow&, sMsg$ 
Dim oColl As Collection 

lLastRow = Worksheets(Worksheets("Summary").Range("A1").Value).Cells(Rows.Count, "H").End(xlUp).Row 
If lLastRow = 1 Then Exit Sub 

vData = Worksheets(Worksheets("Summary").Range("A1").Value).Range("H2:H" & lLastRow) 
Set oColl = New Collection 
For n = LBound(vData) To UBound(vData) 
    On Error Resume Next 
    oColl.Add vData(n, 1), CStr(vData(n, 1)) 
    On Error GoTo 0 
Next n 

For n = 1 To oColl.Count 
    sMsg = oColl(n) 
    Sheets("Summary").Cells(n + 3, 1).Value = Mid$(sMsg, 1) 
Next n 
End Sub 

Одна последняя вещь: вы хотите, чтобы избежать заявлений как Dim oColl As New Collection, и вместо того, чтобы объявить и установить его в два этапа, как я сделал. По этой причине см. Раздел Chip Pearson page и прокрутите вниз до «Не использовать переменные объектов с автоматическим индексированием».

Answer 2

Я показываю код ниже, поскольку он может представлять интерес для OP или других, и является эффективным способом получения уникального списка из столбца данных.

В Excel 2007 или выше мы можем скопировать столбец и воспользоваться функцией Remove Duplicates, чтобы получить наш уникальный список.

Sub CreateUniqueList() 
    Dim lLastRow As Long 
    Dim wsSum As Worksheet 
    Dim rng As Range 

    Set wsSum = Worksheets("Summary") 
    lLastRow = wsSum.Cells(Rows.Count, "H").End(xlUp).Row 
    If lLastRow = 1 Then Exit Sub 

    wsSum.Range("H2:H" & lLastRow).Copy wsSum.Cells(4, 1) 
    wsSum.Range(wsSum.Cells(4, 1), wsSum.Cells(4 + lLastRow - 2, 1)). _ 
     RemoveDuplicates Columns:=1, Header:=xlNo 
End Sub 

Единственным небольшим недостатком является то, что мы сначала должны скопировать весь столбец, но это мелочи по сравнению с ростом производительности для большого набора данных.