If и L oop функция для извлечения данных

Question

В приведенном выше примере набора данных я пытаюсь использовать функцию If VBA для поиска определенного ключевого слова c и если есть совпадение, я бы хотел извлечь само Имя вместе с его серийным номером и продуктом и добавить в последнюю строку другого листа в той же книге.

Например, Если в столбце C, мы обнаруживаем, скажем, can (обратите внимание, что это не точное совпадение, но достаточно хорошее), тогда я бы хотел, чтобы VBA помог мне извлечь Canary Wharf , его Серийный номер и Продукт рядом с ним, то есть 8273615 и Консервы , до конца другого листа и l oop продолжается до конца Кэнэри-Уорф и переходит к Ривердейлу, который я набрал бы, скажем, riverd и повторил тот же процесс. Символы x означают, что у меня довольно большой набор данных, и ничего больше.

Я получил некоторые подсказки с ответом из топа, найденным в Использование "Если клетка содержит" в VBA excel , это очень помогает, но я не могу точно понять, что делать. Буду очень признателен за любую помощь!

Ниже должна быть интуиция:

Option Compare Text

Sub DataExtraction()

Dim SrchRng As Range, cel As Range
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")


Set SrchRng = ws1.Range("C:C")

For Each cel In SrchRng
    If InStr(1, cel.Value, "cana") > 0 Then
        ActiveCell.Value = "Canary Wharf"

    End If
Next cel

End Sub

Используя приведенный выше код, мне удалось получить ActiveCell.Value, чтобы стать Canary Wharf, однако, Мне нужен код l oop до тех пор, пока не останется больше Кэнэри-Уорф, и одновременно скопировать два входа справа от него.

Answer 1

Вы можете использовать пользовательскую форму для ввода того, что вы хотите найти, и использовать range.find

Dim C as Integer

C = Range("C:C").Find(Userform1.Value).Row

Answer 2

Вы можете сделать что-то вроде этого:

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("C:C"), ws.UsedRange)

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

    For Each cel In SrchRng.Cells
        If InStr(1, cel.Value, "cana") > 0 Then
            rngDest.Value = "Canary Wharf"
            rngDest.offset(0, 1).value = cel.offset(0, 1).value
            rngDest.offset(0, 2).value = cel.offset(0, 2).value
            Set rngDest = rngDest.offset(1, 0) '<< next row down
        End If
    Next cel

End Sub