Собрать бирки, ценники обратно в таблицу

Option Explicit
 
Private arr() As Variant, bDebug As Boolean
 
Public Sub Бирко_Собиратель_aka_Страж_Матрицы()
    bDebug = 0
    Application.ScreenUpdating = IIf(bDebug, 1, 0)
 
    'на ws_dest проходит по первой строке
    'и формирует столбцы из значений ws_Sour
    ' http://www.excelworld.ru/forum/2-38118-1
 
    Dim ws_Sour As Worksheet, ws_dest As Worksheet
    Set ws_Sour = ActiveWorkbook.Worksheets("Лист1")
    Set ws_dest = ActiveWorkbook.Worksheets("Накопитель")
 
    Dim iCol_dest As Long, str As String
    With ws_dest
        For iCol_dest = 1 To .UsedRange.Columns.Count
            ReDim arr(0)
 
            Массив_Найденных ws_Sour, .Cells(1, iCol_dest).Value
 
            If UBound(arr) > 0 Then _
               .Cells(2, iCol_dest).Resize(UBound(arr), 1) = _
                Application.WorksheetFunction.Transpose(arr)
        Next
    End With
End Sub
 
Private Sub Массив_Найденных(ws As Worksheet, str As String)
    'нахожу все вхождения str
    Dim rng As Range, firstAddress As String
 
    With ws.Cells
        Set rng = .Find(str, LookIn:=xlValues)
        If Not rng Is Nothing Then
 
            If bDebug Then ws.Activate: rng.Select
 
            firstAddress = rng.Address
            arr(UBound(arr)) = Первый_Кто_Встретился(rng)
            Do
                Set rng = .FindNext(rng)
 
                ReDim Preserve arr(UBound(arr) + 1)
 
                If rng Is Nothing Then Exit Do    '=>
 
                If bDebug Then ws.Activate: rng.Select
 
                arr(UBound(arr)) = Первый_Кто_Встретился(rng)
 
            Loop While rng.Address <> firstAddress
        End If
    End With
End Sub
 
Private Function Первый_Кто_Встретился(rng As Range) As Variant
    'ищет вправо по строке первую непустую ячейку
    Dim iCol As Long
 
    With rng.Parent
        For iCol = rng.Column + 1 To .Columns.Count
 
            If .Cells(rng.Row, iCol).Value <> vbNullString Then
 
                If bDebug Then .Activate: .Cells(rng.Row, iCol).Select
 
                Первый_Кто_Встретился = .Cells(rng.Row, iCol).Value
                Exit For    ' =>
            End If
        Next
    End With
End Function