Работа с коллекциями в VBA

Пользователь

Сообщений: 96 Регистрация: 01.01.1970

01.11.2013 12:53:50

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

Заранее благодарен.

Код

Sub Collections()
    Dim Names As New Collection
    Dim NamesNew As New Collection
    Dim NamesC3 As New Collection
    Dim NamesR1 As Range
    Dim NamesR2 As Range
    Dim cell As Range
        
    Set NamesR1 = ThisWorkbook.Sheets(1).Range("A1:A3")
    Set NamesR2 = ThisWorkbook.Sheets(1).Range("B1:B5")
        
    On Error Resume Next
    For Each cell In NamesR1
            Names.Add cell.Value, CStr(cell.Value)
    Next cell
    
    For Each cell In NamesR2
        Names.Add cell.Value, CStr(cell.Value)
        If Err.Number <> 457 Then
            NamesNew.Add cell.Value, CStr(cell.Value)
        End If
    Next cell
    On Error GoTo 0
    Debug.Print NamesNew.Count
    
End Sub

Прикрепленные файлы

Collections TEST.xlsm (11.78 КБ)

Изменено: Дмитрий Полищук - 01.11.2013 21:30:00

SkyPro

Пользователь

Сообщений: 309 Регистрация: 23.07.2013

01.11.2013 13:28:38

Можно проверять совпадения через массивы.
Проверять нужно больший в меньшем.

Код

Sub lishnie()
Dim ar1, ar2
Dim x&, y&, v&
Dim cl As New Collection

ar1 = [a1:a3]
ar2 = [b1:b5]

On Error Resume Next
For x = 1 To UBound(ar2)
    v = 0
    For y = 1 To UBound(ar1)

        If ar2(x, 1) = ar1(y, 1) Then
            v = v + 1
        End If
    Next
    If v = 0 Then
        cl.Add ar2(x, 1), ar2(x, 1)
    End If
Next

For i = 1 To cl.Count
    Debug.Print cl.Item(i)
    Cells(i, 3).Value = cl.Item(i)
Next

End Sub

Прикрепленные файлы

Collections TEST.xlsm (15.66 КБ)

SkyPro

Дмитрий Пользователь Сообщений: 96 Регистрация: 01.01.1970	#3 01.11.2013 13:32:44 Благодарю)

Слэн

Пользователь

Сообщений: 5192 Регистрация: 16.01.2013

01.11.2013 13:37:55

надо очищать ошибку каждый раз:

Код

Sub Collections()
    Dim Names As New Collection
    Dim NamesNew As New Collection
    Dim NamesC3 As New Collection
    Dim NamesR1 As Range
    Dim NamesR2 As Range
    Dim cell As Range
        
    Set NamesR1 = ThisWorkbook.Sheets(1).Range("A1:A3")
    Set NamesR2 = ThisWorkbook.Sheets(1).Range("B1:B5")
        
    On Error Resume Next
    For Each cell In NamesR1
            Names.Add cell.Value, CStr(cell.Value)
    Next cell
    
    For Each cell In NamesR2
        Err.Clear
        Names.Add cell.Value, CStr(cell.Value)
        If Err.Number <> 457 Then
            NamesNew.Add cell.Value, CStr(cell.Value)
        End If
    Next cell
    On Error GoTo 0
    Debug.Print NamesNew.Count
End Sub

Живи и дай жить..

Читают тему