Копировать значение из ячейки в одном листе в ячейку в последнем использованном столбце на другом листе, если значения в двух других значениях столбцов совпадают

Это может быть невозможно с помощью VBA. У меня есть регистр архитектурных чертежей, который использует 1 строку на чертеж с отдельными столбцами для номера чертежа, имени чертежа, масштаба и размера бумаги. Выпущенная информация отслеживается из столбца «O» и далее.

Когда информация выдается, текущий пересмотр этой информации помечен под датой ее выпуска.

Программное обеспечение, которое мы используем для разработки нашей информации о чертеже, содержит данные, включая самую последнюю версию. То, что я пытаюсь сделать, – это экспортировать номер чертежа и текущие значения версии, чтобы преуспеть, а затем автоматически довести эту информацию до последней даты выпуска в регистре чертежа в правильной строке. Я надеялся обеспечить правильную строку, выполнив поиск содержимого Sheet1 (000 MODELS, ACAD …) Столбец A с содержимым Sheet3 («Revisions») Столбец A и когда он найдет соответствие на Sheet1, скопируйте соответствующую ячейку Sheet3 из столбца B в последний столбец совпадающих строк.

Пока (обновленное изображение): я ранее обновлял упрощенную версию листа, но теперь загрузил исходную версию.

Как вы можете видеть на изображении листа 1, есть две кнопки. Тот, который скрывает все проблемы перед подсказкой даты ввода и Update Revisions, которая еще не работает …

Sheet2 (List) используется исключительно для хранения значений, используемых в макровычислениях и вычислениях данных (не хватает репутаций для размещения третьей ссылки …). Последний номер столбца записывается как значение в элементе Sheet3 cell AA3 из-за макроса findCol, который я использую для кнопки «Скрыть / Показать старые выпуски», который, я надеюсь, можно использовать для определения столбца для копирования текущей версии на , Столбцы AA и AJ хранят информацию, используемую в этом макросе.

Sheet3 (ревизии) содержит экспортированный номер чертежа и текущую ревизию для каждого чертежа, экспортированного из Revit. Для процесса я вижу, что эти данные должны быть скопированы с экспортированного «автономного» листа excel, который позволяет заполнить лист с текущими версиями и затем удален.

Кусок кода, с которым у меня возникают проблемы, заключается в том, где я пытаюсь найти подходящее значение в столбце H на Sheet1 для значений в Sheet3. Когда найдено совпадение, я хочу скопировать значение ячейки из Sheet3 в последний столбец соответствующей строки в Sheet1.

Sub updateRevs() Set i = Sheets("Sheet1") Set r = Sheets("Revisions") Dim d d = 1 Dim j As Range Dim LastRow As Long LastRow = r.Range("A" & Rows.Count).End(xlUp).Row Do Until IsEmpty(r.Range("A" & j)) For j = 1 To LastRow If r.Range("A" & d).Value = i.Range(j, 8).Value Then r.Range("B" & d).Copy i.Range(j, Sheet2.Range("AA3").Value).PasteSpecial xlPasteValues End If Next j d = d + 1 Loop End Sub 

Порядок вызова макроса для кнопки «Обновить версии» выглядит следующим образом:

 Sub MakeNewSheet() Sheets.Add.Name = "Revisions" End Sub Sub copyRevisions() Application.FileDialog(msoFileDialogFilePicker).Show Sheet2.Range("AJ1").Value = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1) Dim x As Workbook Dim y As Workbook lastRow = Range("A" & Rows.Count).End(xlUp).Row Set x = ThisWorkbook Set y = Workbooks.Open(Sheet2.Range("AJ1").Value) y.Sheets("Revisions").Range("A1:B" & lastRow).Copy x.Sheets("Revisions").Range("A1").PasteSpecial Application.CutCopyMode = False y.Close End Sub Sub updateRevs() Set i = Sheets("Sheet1") Set r = Sheets("Revisions") Dim d d = 1 Dim j As Range Dim LastRow As Long LastRow = r.Range("A" & Rows.Count).End(xlUp).Row Do Until IsEmpty(r.Range("A" & j)) For j = 1 To LastRow If r.Range("A" & d).Value = i.Range(j, 8).Value Then r.Range("B" & d).Copy i.Range(j, Sheet2.Range("AA3").Value).PasteSpecial xlPasteValues End If Next j d = d + 1 Loop End Sub Sub deleteRevSheet() Application.DisplayAlerts = False Sheets("Revisions").Delete End Sub 

Любая помощь будет высоко оценена (даже сказать, что это возможно или нет в VBA!)

Благодаря!

Обновленный рабочий код, который, вероятно, требует тонкой настройки:

 Sub updateRevisions() Dim i As Worksheet Dim r As Worksheet Dim LastRow As Long Dim LastRowSheets As Long Set i = ThisWorkbook.Sheets("000 MODELS, ACAD...") Set r = ThisWorkbook.Sheets("Revisions") Dim FirstAddress As String Dim Rng As Range Dim e As Long Dim check() As String Dim cell As Range Dim j As Integer j = 1 Dim Col As Long Col = Sheet2.Range("AB1").Value LastRow = r.Cells(Rows.Count, "A").End(xlUp).Row LastRowSheets = i.Cells(Rows.Count, "H").End(xlUp).Row With Application .ScreenUpdating = False .EnableEvents = False End With With Sheet1.Range("H51:H" & LastRowSheets) ReDim check(j) For Each cell In r.Range("A2:A" & LastRow) check(j) = cell For e = LBound(check()) To UBound(check()) Set Rng = .Find(What:=check(j), _ After:=.Cells(.Cells.Count), _ LookIn:=xlFormulas, _ LookAt:=xlWhole, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not Rng Is Nothing Then FirstAddress = Rng.Address Do Rng.Offset(0, Col).Value = r.Cells(j + 1, "B").Value Set Rng = .FindNext(Rng) Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress End If Next e j = j + 1 ReDim Preserve check(j) Next End With With Application .ScreenUpdating = True .EnableEvents = True End With End Sub 

Sub updateRevs не может работать из-за нескольких проблем:

  1. Вы объявляете j чтобы быть диапазоном, но затем используйте его как число.
  2. Строка, в которой вы устанавливаете LastRow , не является явной и должна включать лист ( r.Rows.Count ).
  3. Цикл Do Until никогда не закончится, потому что j просто переходит от 1 к LastRow (который все еще содержит данные). Итак, вот бесконечный цикл, который заставляет код работать вечно. Я не совсем уверен, чего вы хотите достичь здесь. Поэтому я не знаю, что предложить в качестве улучшения.
  4. Вы использовали иногда Range с двумя числами для ссылки на ячейку. Тем не менее, это возможно только с помощью Cells . Итак, я изменил некоторые из них на Cells . Тем не менее, ссылка здесь – Cells(rowNumber, columnNumber) . Таким образом, вы можете просмотреть эти изменения.

Вот получившийся код после этих изменений:

 Sub updateRevs() Dim d As Long Dim j As Long Dim LastRow As Long Dim i As Worksheet Dim r As Worksheet d = 1 Set i = ThisWorkbook.Sheets("Sheet1") Set r = ThisWorkbook.Sheets("Revisions") LastRow = r.Range("A" & r.Rows.Count).End(xlUp).Row Do Until IsEmpty(r.Range("A" & j)) For j = 1 To LastRow If r.Range("A" & d).Value = i.Cells(j, 8).Value Then r.Range("B" & d).Copy i.Cells(j, Sheet2.Range("AA3").Value).PasteSpecial xlPasteValues End If Next j d = d + 1 Loop End Sub 

Как уже упоминалось ранее, этот код приведет к бесконечному циклу и его необходимо будет скорректировать. Скорее всего, вы можете полностью удалить петлю. Тем не менее, я не знаю, для чего d = d + 1 ?!

Обратите также внимание на то, что этот «ответ» представляет собой скорее набор подсказок, чтобы привести вас в правильном направлении (а не полный ответ). Это связано с тем, что в настоящее время мне не представляется возможным увидеть, чего вы хотите достичь с помощью своей петли.

Interesting Posts

VBA – Кнопка Submit (Вход)

Добавление числа на сегодняшний день, когда число находится в одной ячейке, а дата – в другом – VBA

Значение по умолчанию для Excel VBA ComboBox

Изменить рабочий лист Добавить () без автоматического обновления

Мне нужно обходное решение для проблемы с данными Excel Guessing Data

Как использовать excel в MS Visual C ++

Вставьте разрывы страниц в Excel для разделения данных для печати .pdf

Как экспортировать данные из формы в файл XLSX на Remedy 9.1

Проверьте, существует ли листок в Excel и записывается результат как Boolean

Доступ к VBA – быстрый способ изменения значений ячейки Excel на большом диапазоне?

Найти совпадение, и если true заменить

Строка поиска для определенного текста и, если имеется, скопируйте и вставьте его в ту же строку и пустой столбец

Возвращает значения в той же строке путем поиска в разных столбцах

= функция фильтрации для Excel, как в таблицах Google?

Текст для строк VBA Excel

Давайте будем гением компьютера.