Копирование данных с одной книги в другую - VBA

Формулировка задачи:

Здравствуйте. Помогите пожалуйста с задачей, а именно: ко мне приходит файл с данными книга Б, там находится n количество таблиц, мне нужно взять только определенный столбец из определенных таблиц. Т.е. контрольные образцы и те, что с ними сравнивают к примеру, в прикрепленном файле надо скопировать столбец начиная со строки Мг/л и до конца, сначала из таблицы которая выделена зеленым, потом из красной, потом следующая зеленая табл, красная и так до конца. Копировать нужно в книгу А, по формату представленную в ней, т.е. столбик за стобиком В идеале мне нужно получить сводную таблицу как приложенная книга А, т.е. пройтись по всей книге Б, и скопировать столбцы из каждой подсвеченной таблицы всей книги (листов может быть с десяток). P.S. если реализовать выборку по цвету невозможно, предложите как их отделить друг от друга (м.б. так Лаб №4133(контр), Лаб №4106(подконтр)), т.е. книгу Б можно подредактировать для удобства реализации данной задачи и потом использовать как шаблон. Задача, как мне кажется, очень сложная в плане многочисленных условий, но я буду очень рад любой помощи и советам. Заранее благодарен.

Решение задачи: «Копирование данных с одной книги в другую»

textual
                            Листинг программы 
                        
 
                            
                        
Option Explicit
 
Sub Obnovit()
    Dim wbp As Workbook: Set wbp = ActiveWorkbook
    Dim shp As Worksheet: Set shp = wbp.Worksheets("Лист1")
    Dim lcp, m(), sln: Set sln = CreateObject("Scripting.Dictionary")
    Dim wbi As Workbook, fil, mi()
    Dim shi As Worksheet, rx As Range, rx2 As Range, addres
    Dim rn As Range, fnd: fnd = "Лаб"
    Dim r!, t, zv, lsp, i, lcj
    
    'очистка листа1 от значений, заливки и памок
    With shp
         lcp = .Cells(.Rows.Count, 3).End(xlUp).Row
         m = .Range("C1").Resize(lcp).Value
         Set rx = .Range("D4").Resize(55, shp.UsedRange.Columns.Count)
         rx.ClearContents
         rx.Interior.ColorIndex = 0
         rx.Borders.LineStyle = 0
    End With
    
    Application.ScreenUpdating = False ' что б не моргало и быстрей работало
    
    For r = 8 To lcp ' заливаем в словарь номера строк ионов на случай если в таблицах будет перепутано
        t = m(r, 1)
        If InStr(1, t, "ион") = 0 Then
            sln(t) = r
        End If
    Next r
    
    'ищем рядом файл но не активную книгу
    fil = Dir(wbp.Path & "\*.xlsx")
    Do While fil = wbp.Name
       fil = Dir
    If Len(fil) = 0 Then Exit Sub
    Loop
    
    'собираем путь и открываем книгу
    fil = wbp.Path & "" & fil
    Set wbi = Workbooks.Open(fil)
    
    
    For Each shi In wbi.Worksheets ' перебираем листы в книге
        With shi
            Set rn = .Columns("A:D") ' где искать
            Set rx = rn.Cells.Find(fnd, After:=.Cells(1, 1)) ' ищем начиная сверху
            If Not rx Is Nothing Then ' если нашли
                addres = rx.Address ' запоминаем адрес что бы на зациклилось
                Do ' начинаем цикл по всем таблицам в первом столбце таблиц колонки A-D
                r = rx.Row ' строка с найденным значением
                    lcj = Cells(6, shp.Columns.Count).End(xlToLeft).Column + 1 ' последняя занятая ячейка в найденной строке
                    For c = 1 To lcj ' по всем ячейкам строки
                        If InStr(1, .Cells(r, c), "лаб", vbTextCompare) > 0 Then ' если в ячейке есть "лаб"
                            Set rx2 = .Cells(r, c) ' назначаем переменноой (не обязательно, но записи дальше будут короче)
                            If rx2.Interior.ColorIndex <> 0 And rx2.Interior.ColorIndex <> xlNone Then ' если залита любым цветом
                                mi = rx2.Resize(63, 2).Value ' считываем в массив
                                zv = rx2.Interior.ColorIndex ' и запоминаем цвет
                                lsp = shp.Cells(6, shp.Columns.Count).End(xlToLeft).Column + 1 ' находим первую пустую ячейку в 6 строке на листе приёма данных
                                shp.Cells(4, lsp) = Split(mi(1, 1), "№")(1) ' выделяем номер лаб и записываем в ячейку( можно было бы писать в массив и потом вываливать на лист. Было бы быстрее
                                shp.Cells(6, lsp) = "Мг/л"
                                For i = 8 To UBound(mi) ' по считанному массиву значений
                                    t = sln(mi(i, 1)) ' из словаря находим номер строки иона
                                    If Len(t) > 0 Then ' если есть номер строки. Может не оказаться в случае опечатки
                                        shp.Cells(t, lsp) = mi(i, 2) ' записываем значение
                                    End If
                                Next i
                             shp.Cells(6, lsp).Resize(52).Interior.ColorIndex = zv ' заливаем цветом лабы блок ячеек
                            End If
                        End If
                    Next c ' следующая ячейка в строке
                   Set rx = rn.Cells.FindNext(rx) ' ищем следующую таблицу на листе в колонках A-D
                Loop While addres <> rx.Address ' повторяем цикл если адрес найденной ячейки не равен первому
            End If
        End With
    Next
    wbi.Close False
    shp.Range("D34").Resize(, lsp - 3).FormulaR1C1 = "=SUM(R[-26]C:R[-1]C)" ' вбиваем формулы
    shp.Range("D46").Resize(, lsp - 3).FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)" ' вбиваем формулы
    shp.Range("D6").Resize(52, lsp - 3).Borders.LineStyle = 1 ' делаем рамку
    Application.ScreenUpdating = True
End Sub