Поиск значения в другой книге - VBA
Формулировка задачи:
Доброго дня.
Появилась задачка, которую пока не получается реализовать.
Есть два Excel файла: "Книга 1" и "Книга 2". Книга 1 находится на рабочем столе. Книга 2 - в сетевой папке (\\test\Документы для проверки\Книга 2.xlsx)
В Книге 1 есть 3 интересующих столбца: C, E, J, а также кнопка (назовем ее "старт") привязанная к процедуре. В Книге 2, так же есть интересующие столбцы: D, J, M.
Теперь сама задачка. При выделении ячейки C3 и нажатии кнопки "старт", происходит поиск значения выделенной ячейке в Книге 2 столбца D, и если такое значение находится (к примеру значение найдено в ячейке D41), то скопировать значение ячеек E3 и J3 в ячейки J41 и M41 соответственно и окрасить в зеленый цвет ячейку D41.
P.S. VBA, конечно, немного отличается от VB.NET
Решение задачи: «Поиск значения в другой книге»
textual
Листинг программы
Sub CopyValues() Dim ID As String, Serial As String, Location As String, extWbValue As String, actCell As String Dim ExtRange As Range, rgResult As Range Dim extwbk As Workbook Dim objExtwb As Object Const extWb = "\\test\Документы для проверки\Книга 2.xlsx" 'Путь к книге 2 Set objExtwb = GetObject(extWb) actCell = ActiveCell.Address 'Адрес активной ячейки ID = ActiveCell.Value 'Значение активной ячейки Serial = Range(actCell).Offset(, 2) 'Серийный номер (смещение на 2 ячейки вправо от выделенной) If Range(actCell).Offset(, 7).MergeCells Then Location = Range(actCell).Offset(, 7).MergeArea.Cells(1, 1).Value 'Местоположение (смещение на 7 ячеек вправо от выделенной) Else Location = Range(actCell).Offset(, 7) End If Range(actCell).Interior.Color = RGB(0, 178, 80) Set ExtRange = objExtwb.Worksheets("Sheet1").Range("D2:D4000") extWbValue = Application.WorksheetFunction.VLookup(ID, ExtRange, 1, False) Set rgResult = ExtRange.Find(extWbValue, , xlValues) objExtwb.Worksheets("Sheet1").Range(rgResult.Address).Interior.Color = RGB(0, 178, 80) objExtwb.Worksheets("Sheet1").Range(rgResult.Address).Offset(, 6).NumberFormat = "@" objExtwb.Worksheets("Sheet1").Range(rgResult.Address).Offset(, 6).Value = Serial objExtwb.Worksheets("Sheet1").Range(rgResult.Address).Offset(, 9).NumberFormat = "@" objExtwb.Worksheets("Sheet1").Range(rgResult.Address).Offset(, 9).Value = Location Range(actCell).Offset(1, 0).Select objExtwb.Save Set objExtwb = Nothing End Sub
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д