Поиск значения в другой книге - 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
Листинг программы
  1. Sub CopyValues()
  2. Dim ID As String, Serial As String, Location As String, extWbValue As String, actCell As String
  3. Dim ExtRange As Range, rgResult As Range
  4. Dim extwbk As Workbook
  5. Dim objExtwb As Object
  6. Const extWb = "\\test\Документы для проверки\Книга 2.xlsx" 'Путь к книге 2
  7. Set objExtwb = GetObject(extWb)
  8. actCell = ActiveCell.Address 'Адрес активной ячейки
  9. ID = ActiveCell.Value 'Значение активной ячейки
  10. Serial = Range(actCell).Offset(, 2) 'Серийный номер (смещение на 2 ячейки вправо от выделенной)
  11. If Range(actCell).Offset(, 7).MergeCells Then
  12. Location = Range(actCell).Offset(, 7).MergeArea.Cells(1, 1).Value 'Местоположение (смещение на 7 ячеек вправо от выделенной)
  13. Else
  14. Location = Range(actCell).Offset(, 7)
  15. End If
  16. Range(actCell).Interior.Color = RGB(0, 178, 80)
  17. Set ExtRange = objExtwb.Worksheets("Sheet1").Range("D2:D4000")
  18. extWbValue = Application.WorksheetFunction.VLookup(ID, ExtRange, 1, False)
  19. Set rgResult = ExtRange.Find(extWbValue, , xlValues)
  20. objExtwb.Worksheets("Sheet1").Range(rgResult.Address).Interior.Color = RGB(0, 178, 80)
  21. objExtwb.Worksheets("Sheet1").Range(rgResult.Address).Offset(, 6).NumberFormat = "@"
  22. objExtwb.Worksheets("Sheet1").Range(rgResult.Address).Offset(, 6).Value = Serial
  23. objExtwb.Worksheets("Sheet1").Range(rgResult.Address).Offset(, 9).NumberFormat = "@"
  24. objExtwb.Worksheets("Sheet1").Range(rgResult.Address).Offset(, 9).Value = Location
  25. Range(actCell).Offset(1, 0).Select
  26. objExtwb.Save
  27. Set objExtwb = Nothing
  28. End Sub

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


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

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

12   голосов , оценка 4.167 из 5

Нужна аналогичная работа?

Оформи быстрый заказ и узнай стоимость

Бесплатно
Оформите заказ и авторы начнут откликаться уже через 10 минут
Похожие ответы