Поиск дважды

Загрузка рабочей книги (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