Поиск дважды

Загрузка рабочей книги (Dropbox)

Sub SearchTwice()

    Const cSheet As String = "Sheet2"   ' Source Worksheet Name
    Const cList As String = "C3"        ' List Cell Range Address
    Const cName As String = "D3"        ' Name Cell Range Address
    Const cListCol As String = "A"      ' List Column Letter
    Const cNameCol As String = "C"      ' Name Column Letter
    Const cFirst As Long = 6            ' First Row
    Const cCol As Long = 3              ' Number of Columns

    Dim rng1 As Range       ' Find List Cell Range
                            ' Found Name Cell Range
    Dim rng2 As Range       ' Next List Cell Range
                            ' Name Search Range
    Dim strList As String   ' List
    Dim strName As String   ' Name

    ' In Source Worksheet
    With ThisWorkbook.Worksheets(cSheet)
        ' Write from List Cell Range to List.
        strList = .Range(cList)
        ' Write from Name Cell Range to Name.
        strName = .Range(cName)
        ' Check if Cell Ranges do NOT contain data.
        If strList = "" Or strName = "" Then  ' Inform user.
            MsgBox "Missing List or Name.", vbCritical, "Missing data"
            Exit Sub
        End If
         ' In List Column
        With .Columns(cListCol)
            ' Create a reference to Find List Cell Range (rng1) containing
            ' List (strList).
            Set rng1 = .Find(strList, .Cells(cFirst - 1), xlValues, xlWhole)
            ' Check if List has not been found.
            If rng1 Is Nothing Then   ' Inform user and exit.
                MsgBox "The list '" & strList & "' has not been found", _
                        vbCritical, "List not found"
                Exit Sub
            End If
            ' Create a reference to Next List Cell Range (rng2).
            Set rng2 = .Find("*", .Cells(rng1.Row), xlValues, xlWhole)
        End With
        ' In Name Column
        With .Columns(cNameCol)
            ' Check if the row of Next List Cell Range (rng2) is greater than
            ' the row of List Cell Range (rng1) i.e. if a cell with a value
            ' has been found below List Cell Range (rng1) in List Column.
            If rng2.Row > rng1.Row Then   ' Next List Cell Range FOUND.
                ' Create a reference to Name Search Range (rng2) which spans
                ' from the cell below Find List Cell Range (rng1) to the cell
                ' above the Next List Cell Range (rng2), but in Name Column.
                Set rng2 = .Cells(rng1.Row + 1).Resize(rng2.Row - rng1.Row - 1)
              Else                        ' Next List Cell Range NOT found.
                ' Create a reference to Name Search Range (rng2) which spans
                ' from the cell below Find List Cell Range (rng1) to the bottom
                ' cell, but in Name column.
                Set rng2 = .Cells(rng1.Row + 1).Resize(.Rows.Count - rng1.Row)
            End If
        End With
        ' In Name Search Range (rng2)
        With rng2
            ' Create a reference to Found Name Cell Range (rng1).
            Set rng1 = .Find(strName, .Cells(.Rows.Count), xlValues, xlWhole)
        End With

        ' Check if Name has not been found.
        If rng1 Is Nothing Then   ' Inform user and exit.
            MsgBox "The name '" & strName & "' has not been found", _
                    vbCritical, "Name not found"
            Exit Sub
        End If

        ' Remarks:
        ' Source Range is calculated by moving the Found Name Cell Range (rng1)
        ' one cell to the right and by resizing it by Number of Columns (cCol).
        ' Target Range is calculated by moving the Name Cell Range one cell
        ' to the right and by resizing it by Number of Columns (cCol).

        ' Copy values of Source Range to Target Range.
        .Range(cName).Offset(, 1).Resize(, cCol) _
                = rng1.Offset(, 1).Resize(, cCol).Value

    End With

    ' Inform user of succes of the operation.
    MsgBox "The name '" & strName & "' was successfully found in list '" & _
            strList & "'. The corresponding data has been written to the " _
            & "worksheet.", vbInformation, "Success"

End Sub

Решение VBA

Я думаю, что решение без VBA здесь идеально, но я оставлю это здесь отдельно на всякий случай. Это должно работать в вашей ситуации, если в ваших таблицах нет пустых значений.

    Sub Test()

    Dim ws As Worksheet: Set Worksheet = ThisWorkbook.Sheets("Sheet2")
    Dim iList As Range, iName As Range
    Dim aLR As Long, cLR As Long

    aLR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

    Set iList = ws.Range("A1:A" & aLR).Find(ws.Range("C3"), LookIn:=xlWhole)

    If Not iList Is Nothing Then
        cLR = iList.Offset(0, 2).End(xlDown).Row
        Set iName = ws.Range(ws.Cells(iList.Row, 3), ws.Cells(cLR, 3)).Find(ws.Range("C4"), LookIn:=xlWhole)
            If Not iName Is Nothing Then
                ws.Range("E3:G3").Value = iName.Offset(0, 1).Resize(1, 3).Value
            End If
    End If

    End Sub

Одной из причин усталости является то, что вы пытались пойти на убийство, прежде чем приступить к бойне. Приведенное ниже решение заняло час, чтобы подготовиться и 10 минут, чтобы закодировать. Вставьте весь код в стандартный модуль кода и вызовите функцию MatchRow либо из окна Immediate (? MatchRow), либо из собственного кода, как показано ниже в тестовом процессе.

Option Explicit

Enum Nws                            ' worksheet navigation
    ' 01 Mar 2019
    NwsCriteriaRow = 3
    NwsList = 1                     ' Columns: (1 = A)
    NwsID = 3
    NwsNumber                       ' (undefined: assigns next integer)
End Enum

Function MatchRow() As Long
    ' 01 Mar 2019
    ' return 0 if not found

    Dim Ws As Worksheet
    Dim Rng As Range
    Dim R As Long

    ' The ActiveWorkbook isn't necessarily ThisWorkbook
    Set Ws = ActiveWorkbook.Worksheets("Sheet2")        ' replace tab's name here
    With Ws
        Set Rng = .Range(.Cells(NwsCriteriaRow, NwsList), .Cells(.Rows.Count, NwsList).End(xlUp))
        R = FindRow(.Cells(NwsCriteriaRow, NwsID).Value, Rng, True)

        If R Then                                       ' skip if no match was found
            Set Rng = .Cells(R + 1, NwsID)
            Set Rng = .Range(Rng, Rng.End(xlDown))
            MatchRow = FindRow(.Cells(NwsCriteriaRow, NwsNumber).Value, Rng)
        End If
    End With
End Function

Private Function FindRow(Crit As Variant, _
                         Rng As Range, _
                         Optional ByVal SearchFromTop As Boolean) As Long
    ' 01 Mar 2019
    ' return 0 if not found

    Dim Fun As Range
    Dim StartCell As Long

    With Rng
        If SearchFromTop Then
            StartCell = 1
        Else
            StartCell = .Cells.Count
        End If

        Set Fun = .Find(What:=Crit, _
                       After:=.Cells(StartCell), _
                       LookIn:=xlValues, _
                       LookAt:=xlWhole, _
                       MatchCase:=False)
    End With

    If Not Fun Is Nothing Then FindRow = Fun.Row
End Function

Функция MatchRow возвращает номер строки Sheet2, где D3 найден, ища только ту часть столбца D, которая принадлежит списку, указанному в C3. Функция возвращает 0, если совпадений не найдено ни в списке, ни в ID.

Вы не указали, что вы хотите сделать с найденным рядом. Процедура ниже вернет данные из этой строки. Вместо этого вы можете использовать возможность адресации ячеек для записи в них.

Private Sub RetrieveData()

    Dim R As Long

    R = MatchRow
    MsgBox "ID = " & Cells(R, NwsID).Value & vbCr & _
           "Number = " & Cells(R, NwsNumber).Value
End Sub

Будучи предназначенным для тестирования только вышеупомянутого процесса, он не определяет рабочий лист и, следовательно, возвращает данные из ActiveSheet, предположительно Sheet2.

Решение не VBA

1. Преобразование двух диапазонов списка в таблицы
2. Измените имя таблицы на (Formulas Tab > Name Manager > Select Table/Change Name). В частности, вы хотите изменить имена на желаемое имя списка. (Table 1 Name = List1 и Table 2 Name = List2)
3. Затем поместите эти формулы внутрь E3, F3, & G3

  E3 = VLOOKUP(D3, Indirect(C3), 2, 0) 
  F3 = VLOOKUP(D3, Indirect(C3), 3, 0)
  G3 = VLOOKUP(D3, Indirect(C3), 4, 0)

Это будет обновляться динамически, как ваша таблица размеры расширяются. Вы также можете добавить столько таблиц, сколько захотите, и это продолжит работать.

При использовании это выглядит примерно так

Мое последнее предложение - вкладывать каждую формулу выше внутри IFERROR()