Вывод содержания коллекции на лист

Sub start_me()
Dim NewColl As New Collection
 
Randomize Timer
For i = 1 To 20
NewColl.Add Int((100 * Rnd()) + 1)
Next i
 
For j = 1 To NewColl.Count
ThisDocument.Tables(1).Cell(j, 1).Range.Text = NewColl(j)
Next j
 
End Sub

Sub Search_delete()
Dim RegV As New Collection 'коллекция со всеми производителями ("Лист1").Cells(i, "B")
Dim MyV As New Collection 'коллекция с моими производителями ("Лист2").Cells(i, "A")
Dim NewColl As New Collection 'коллекция с  новыми значениями производителей
Dim Allrows As New Collection ' коллекция с индексами строк таблицы производителей
Dim AllTable As New Collection ' коллекция со всеми строками таблицы Вся таблица на Лист 1
Dim i As Integer 'счетчик 1
Dim j As Integer 'счетчик 2
 
'----------------------Наполняем коллекцию всеми строками таблицы Лист1
For i = 1 To 417 'Диапозон строк для наполнения колекции
    AllTable.Add Item:=Sheets("Лист1").Rows(i).Value
Next i
i = 0
'----------------------Наполняем коллекцию моими производителями Лист2
For i = 1 To 133 'Диапазон строк для наполнения колекции
        MyV.Add Item:=Sheets("Лист2").Cells(i, "A").Value
Next i
i = 0
'----------------------Наполняем коллекцию всеми производителями
For i = 1 To 417 'Диапазон строк для наполнения колекции Лист1 Столбец B
    RegV.Add Item:=Sheets("Лист1").Cells(i, "B").Value
Next i
 
i = 0
j = 0
'---------------------Начинаем проверку на совпадение
For j = 1 To RegV.Count 'Лист1 Столбец B
 
    For i = 1 To MyV.Count 'Лист2 Столбец A
            
        If RegV(j) = MyV(i) Then 'Если Производитель из Лист1 Столбец B равен моему производителю Лист2 Столбец A
            Allrows.Add Item:=j 'Заносим индекс строки которая должна остаться
        End If
    Next i
Next j
'MsgBox (NewColl.Count)
i = 0
j = 0
MsgBox (Allrows.Count)
MsgBox (AllTable.Count)
'Заносим в коллекцию NewColl необходимые значения из AllTable строки индекс которых хранится в Allrows
For j = 1 To AllTable.Count
    For i = 1 To Allrows.Count
        If j = Allrows(i) Then
           NewColl.Add Item:=AllTable.Item(j)
             
        End If
    Next i
Next j
 
MsgBox (NewColl.Count)
 
End Sub

Sub Procedure_1()
 
    'Здесь указываем, с какой строки начинаются данные на первом листе.
    Const lStart As Long = 1
 
    Dim shSheet_1 As Excel.Worksheet
    Dim shSheet_2 As Excel.Worksheet
    Dim shSheet_3 As Excel.Worksheet
    Dim lLastRow As Long
    Dim i As Long
    
    'Обращаться к листам для удобства будем через переменные.
    Set shSheet_1 = Worksheets(1)
    Set shSheet_2 = Worksheets(2)
    Set shSheet_3 = Worksheets(3)
    
    'Чтобы код быстрее работал, отключаем обновление монитора.
    Application.ScreenUpdating = False
    
    'Определяем пустую строку на третьем листе, куда надо вставлять данные.
    lLastRow = shSheet_3.Cells(shSheet_3.Rows.Count, "A").End(xlUp).Row + 1
    
    'Двигаемся по первому листу по столбцу B до первой пустой ячейки.
    i = lStart
    Do While IsEmpty(shSheet_1.Cells(i, "B")) = False
        
        'Берём данные из текущей ячейки и ищем на втором листе в столбце A.
        If Not shSheet_2.Columns("A").Find(What:=CStr(shSheet_1.Cells(i, "B").Value), _
                LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
                False, SearchFormat:=False) Is Nothing Then
             
             'Если найдено, то переносим на третий лист в следующую свободную ячейку.
             shSheet_3.Range("A" & lLastRow & ":D" & lLastRow).Value = _
                shSheet_1.Range("A" & i & ":D" & i).Value
             
             'Определяем номер следующей пустой строки на третьем листе.
             lLastRow = lLastRow + 1
        End If
 
        'Переход к следующей строке на первом листе.
        i = i + 1
        
    Loop
    
    'Включаем обновление монитора.
    Application.ScreenUpdating = True
    
    'Сообщение, что работа кода завершена.
    MsgBox "Работа кода завершена!", vbInformation
    
End Sub