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