Поиск значения в другой книге - 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

ИИ поможет Вам:


  • решить любую задачу по программированию
  • объяснить код
  • расставить комментарии в коде
  • и т.д
Попробуйте бесплатно

Оцени полезность:

12   голосов , оценка 4.167 из 5
Похожие ответы