VBA：如何在单元格范围内搜索值，然后返回该位置旁边的单元格？

Question

您好，这是我的第一个问题，所以我将尽我所能来格式化。

下面没有特定单元格名称的快速描述

我正在尝试编写一个宏，用户在其中输入一个值（X），然后宏在一个单元格区域中搜索一个值（X），然后该宏在值的位置旁边的3个空格中返回单元格值（X）是。

使得此问题无法解决的几件事是用户在Sheet1上输入了值，并且该值已通过公式移动到Sheet2，我似乎无法弄清楚如何使用“查找要搜索的值”尚未在宏中定义。

造成这一困难的另一件事是，范围也不是严格定义的，因为列表可能比当前更长或更短，而且我不知道它何时会更改。 因此，必须根据用户输入的列表开始搜索范围，并且需要继续搜索直到列表空白。

例如：Range。（“ C7：D10”）将不起作用，因为用户可以输入新信息来更改工作范围，如下所述。

以下是带有进一步说明的屏幕截图

https://i.stack.imgur.com/wlnhg.jpg

因此，在此屏幕截图中，单元格C3和D3是从Sheet1导入的值。

C3是（= Sheet1！B2）

D3是（= Sheet1！B3）

这个想法是宏运行并向下搜索列A，直到它与C3匹配为止。

然后，搜索功能移至两个单元格上方并向下搜索，直到与D3匹配或碰到空白为止。

我不知道如何让一个宏基于导入的值进行搜索，也不知道如何让它搜索我需要的这个奇怪的特定范围。 这个想法是，我工作的人可能会出现，并在C10下方添加一行并添加必要的信息，该宏仍然可以工作并搜索到C11，并且在告诉宏停止后会有一个空格。

搜索找到D3的匹配项后，它将与该匹配项相邻的值返回到顶部的相应单元格E3，F3和G3。

我希望以人们可以理解的方式提出这个问题，我很累，所以无法分辨我是否写了有意义的东西。 谢谢您阅读我的文章，你们都很棒！

Answer 1

非VBA解决方案

1. 将您的两个列表范围转换为表格
2. 通过（ Formulas Tab > Name Manager > Select Table/Change Name ） 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()

Answer 2

感到疲倦的原因之一是，您在准备宰杀之前就试图将其杀死。 下面的解决方案需要一个小时的准备时间和10分钟的编码时间。 将整个代码粘贴到标准代码模块中，然后从即时窗口（ ? MatchRow ）或从您自己的代码中调用函数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函数返回在其中找到D3的Sheet2的行号，仅搜索D列中属于C3标识的列表的那部分。 如果找不到匹配的列表或ID，则函数返回0。

您未指定要对找到的行执行的操作。 下面的过程将从该行返回数据。 您可能使用该功能来寻址单元以写入它们。

Private Sub RetrieveData()

    Dim R As Long

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

仅用于测试上面的proc并没有指定工作表，因此从ActiveSheet返回假定为Sheet2的数据。

Answer 3

搜索两次

工作簿下载 （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

Answer 4

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