Страницы: 1
RSS
Сравнение коллекций Excel VBA, Вопрос по работе с коллекциями в Excel VBA
 
Всем привет!

Пишу макрос в Excel для выборки данных с одной таблицы одного листа и последующей вставке в другую таблицу на другой лист, с удалением дубликатов.

Логика программы:

1) Под определенным условием, программа выбирает данные из нужных мне ячеек первого листа и заносит её в коллекцию.
2) Аналогично первому пункту, программа проделывает те же действия, но только со второй таблицей на втором листе.
3) Используя "цикл в цикле" программа сравнивает значения первой и второй коллекции, и при совпадении такого - удаляет его из первой коллекции.
4) То что остается в первой коллекции - нужные мне данные с которыми я и буду работать.

ПРОБЛЕМЫ:

1) Для удаление элемента из коллекции нельзя использовать его наименование (пример MyCollection.Remove money). Выход - использовать удаление по ключу, но как я могу прописать к каждому значению ключ, когда элементов может быть более 1000?

2)Даже если свершиться чудо и я найду способ это сделать, как я при удалении элемента из коллекции могу указать ключ именно этого элемента, если я понятия не имею какой дублированный элемент цикл вытащит из коллекции во время очередной итерации?

Как быть?

Ниже прилагаю код программы:


Код
Sub Тестовый()

'Создание точки начала цикла в Operation CIS region'

Set MyOneRange = Range("B1:B100")
Dim MyOneCell As Range
For Each MyOneCell In MyOneRange
 If MyOneCell = "description" And MyOneCell.Interior.Color = "13431551" Then
       StartCell = MyOneCell.Row + 1
End If
Next MyOneCell

'Создание точки конца цикла в Operation CIS region'

Set MyTwoRange = Range("B1:B100")
Dim MyTwoCell As Range
For Each MyTwoCell In MyTwoRange
If MyTwoCell = "description" And MyTwoCell.Interior.Color = "16247773" Then
       LastCell = MyTwoCell.Row - 1
End If
Next MyTwoCell


'Проверка на пустые строки и создание словаря в Operation CIS region'

Dim it As Long
Dim Coll As New Collection
For it = StartCell To LastCell
If Not IsEmpty(Cells(it, 2)) Then
          Coll.Add Cells(it, 2).Value, Cells(it, 2).Value
End If
Next it

'Создание словаря для Cesaretti и запись данных в него'

Set Distance = Worksheets("Cesaretti").Range("F5:F500")
Dim MyFirstRange As Range
Dim MyTotalRange As Range
Dim CollCes As New Collection

For Each MyFirstRange In Distance
    If Not IsEmpty(MyFirstRange) Then
        For Each MyTotalRange In MyFirstRange
        CollCes.Add (MyTotalRange)
        Next MyTotalRange
    End If
Next MyFirstRange


' Сравнение словарей 

For Each CisValue In Coll
   For Each CesValue In CollCes
       If CisValue <> CesValue Then
           Coll.Remove CisValue
       End If
    Next CesValue
Next CisValue


    

'Вставка пустых новых строк в документ Cesaretti'
'Dim i As Long
'MyRange = CollTotal.Count
'For i = 1 To MyRange Step 1
'Worksheets("Cesaretti").Cells(5, i).EntireRow.Insert
'Worksheets("Cesaretti").Cells(5, i).RowHeight = 17.4
'Next i


End Sub
Изменено: Владислав Дорошенко - 22.06.2021 09:25:21
 
Исчерпывающее описание объекта Dictionary - Макросы и программы VBA - Excel - Каталог статей - Perfect Excel (perfect-excel.ru)
Код
Option Explicit

Sub Тестовый()

'Создание точки начала цикла в Operation CIS region'

Set MyOneRange = Range("B1:B100")
Dim MyOneCell As Range
For Each MyOneCell In MyOneRange
If MyOneCell = "description" And MyOneCell.Interior.Color = "13431551" Then
      StartCell = MyOneCell.Row + 1
End If
Next MyOneCell

'Создание точки конца цикла в Operation CIS region'

Set MyTwoRange = Range("B1:B100")
Dim MyTwoCell As Range
For Each MyTwoCell In MyTwoRange
If MyTwoCell = "description" And MyTwoCell.Interior.Color = "16247773" Then
      LastCell = MyTwoCell.Row - 1
End If
Next MyTwoCell


'Проверка на пустые строки и создание словаря в Operation CIS region'

Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")

Dim it As Long
Dim Coll As New Collection
For it = StartCell To LastCell
If Not IsEmpty(Cells(it, 2)) Then
         Coll.Add Cells(it, 2).Value, Cells(it, 2).Value
         dic.Item(Cells(it, 2).Value) = 0
End If
Next it

'Создание словаря для Cesaretti и запись данных в него'

Set Distance = Worksheets("Cesaretti").Range("F5:F500")
Dim MyFirstRange As Range
Dim MyTotalRange As Range
Dim CollCes As New Collection

For Each MyFirstRange In Distance
   If Not IsEmpty(MyFirstRange) Then
       For Each MyTotalRange In MyFirstRange
       CollCes.Add (MyTotalRange)
       dic.Item(MyTotalRange) = 0
       Next MyTotalRange
   End If
Next MyFirstRange


Dim v As Variant
For Each v In dic.Keys
    Debug.Print v
Next

'' Сравнение словарей
'
'For Each CisValue In Coll
'  For Each CesValue In CollCes
'      If CisValue <> CesValue Then
'          Coll.Remove CisValue
'      End If
'   Next CesValue
'Next CisValue


   

'Вставка пустых новых строк в документ Cesaretti'
'Dim i As Long
'MyRange = CollTotal.Count
'For i = 1 To MyRange Step 1
'Worksheets("Cesaretti").Cells(5, i).EntireRow.Insert
'Worksheets("Cesaretti").Cells(5, i).RowHeight = 17.4
'Next i


End Sub
Изменено: МатросНаЗебре - 22.06.2021 09:00:59
 
Владислав Дорошенко, оформите код тэгом <…> на панели
На объёмах до 200 тыс уникальных ключей словари во всём превосходят коллекции (кроме того, что это отдельная библиотека, но это ерунда)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Страницы: 1
Наверх