Если и L oop функция

Question

Основной набор данных - Лист1

Под набор данных - Лист2

По аналогии с вопрос по Если и L oop функция для извлечения данных , у меня есть две таблицы. Я пытаюсь использовать VBA для ввода столбца M для х-х. Например, слева от яблока должно быть 123, так как это его код, и оранжевого 456 и c., Согласно основному набору данных. Поскольку это та же проблема, что и на вышеупомянутом сайте, я немного подправил код, но он не сработал. Это выглядит следующим образом:

Option Compare Text

Sub DataExtraction()

    Dim SrchRng As Range, cel As Range, rngDest as Range
    Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")

    'restrict the search range
    Set SrchRng = Application.Intersect(ws1.Range("F;F"), ws1.UsedRange)

    Set rngDest = ws2.cells(rows.count, 1).end(xlUp).Offset(1, 0) 'start copy here

    For Each cel In SrchRng.Cells
        If cel.value=rngDest.value Then
            rngDest.offset(0, -1).value = cel.offset(0, -1).value
            Set rngDest = rngDest.offset(1, 0) '<< next row down
        End If
    Next cel

End Sub

Короче говоря, я пытаюсь сказать VBA, что если совпадает интересующий фрукт , введите код , найденный в столбце D листа 1 в столбец M листа 2 соответственно, затем переходите к следующему ряду и , повторяйте упражнение. Любая помощь будет принята с благодарностью.

PS Особая благодарность Тиму Уильямсу за решение моей проблемы ранее и помощь в настройке этой модели, которую я использовал для разработки.

Answer 1

Существует простое решение без использования VBA. Вы можете сделать это и с формулами, используя комбинацию MATCH() и INDEX(). Это должно быть даже быстрее.

Просто используйте

=INDEX(Sheet1!D:D,MATCH(N:N,Sheet1!F:F,0))

---

Если вам нужно автоматизировать это, я бы записал эту формулу в столбец M (и при необходимости преобразовал формулы в значения ):

Option Explicit

Public Sub FillInCodes()
    Dim wsSub As Worksheet
    Set wsSub = ThisWorkbook.Worksheets("Sheet2")

    Dim LastRow As Long
    LastRow = wsSub.Cells(wsSub.Rows.Count, "A").End(xlUp).Row

    wsSub.Range("M2:M" & LastRow).Formula = "=INDEX(Sheet1!D:D,MATCH(N:N,Sheet1!F:F,0))"

    'and if you need to convert the formulas into values
    wsSub.Range("M2:M" & LastRow).Value = wsSub.Range("M2:M" & LastRow).Value 
End Sub