Копирование данных с одной книги в другую - 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
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д