使用空白中间单元格复制粘贴整行

对于此解决方案，我在单元格 B2 中创建了一个带有验证下拉列表的工作表，允许选择“姓名”或“姓氏”。我还在 A2 中输入了文本“查找联系人”作为空白单元格 A3 的标题。A3 以下的所有行也是空白的。

请注意，代码中按名称引用了单元格 A3 和 B2。您可以通过更改代码中常量的值将它们的功能转移到同一工作表上的任何其他单元格。您还可以更改其中的列数（现在为 4，正如您所指定的）和包含您的电话列表的工作表的名称（Worksheets("Sheet4")现在）以及指定它的语法。

该ActiveSheet由代码的位置指定。将其粘贴到您的代码标识为Sheets(1)的工作表的代码表中。这个位置至关重要。如果您将代码粘贴到标准代码模块（名称类似于Module1），它将失去其自动化功能。

正确安装后，它将对 A3 和 B2 的变化做出反应。假设您在 B2 中选择了“姓氏”并在 A3 中输入“迈克”，代码将列出所有匹配的数字在 A3:D3 及以下，最多 20 个（您可以在代码中取消或增加） . 但是，“迈克”不是姓氏。因此，代码可能会返回“未找到匹配项”。您现在可以将 B2 中的搜索字段选择器更改为“名称”。这将导致代码在另一列中查找“Mike”并列出找到的所有 Mike。无需再次输入搜索条件。

Private Sub Worksheet_Change(ByVal Target As Range)
    ' 284
    
    Const TriggerAddress    As String = "A3"        ' change to suit
    Const LookUpSpec        As String = "B2"        ' which column to search: change to suit
    Const ClmCount          As Long = 4             ' 4 data columns ("A:D")
    
    Dim Ws                  As Worksheet            ' data source
    Dim LookUpClm           As Long
    Dim Rng                 As Range                ' working range
    Dim Fnd                 As Range                ' search result range
    Dim FirstFound          As Long
    Dim Output              As Variant              ' (maximum 20 rows)
    Dim i                   As Long                 ' index of Output
    Dim C                   As Long                 ' loop counter: columns
    
    With Target
        If .Address = Range(TriggerAddress).Address Or _
           .Address = Range(LookUpSpec).Address Then
           Set Target = Range(TriggerAddress)
        Else
            Exit Sub
        End If
    End With

    Set Ws = Worksheets("Sheet4")           ' change to suit
    LookUpClm = 2 + (StrComp(Range(LookUpSpec).Value, "name", vbTextCompare) = 0)
    ' change LookupSpec colour
    Range(LookUpSpec).Font.Color = Array(12611584, 3506772)(LookUpClm - 1)
    
    With Ws
        ' exclude row 1 (column headers)
        Set Rng = .Range(.Cells(2, LookUpClm), _
                         .Cells(.Rows.Count, LookUpClm).End(xlUp))
    End With
    ReDim Output(1 To ClmCount, 1 To 20)     ' maximum = 20: modify here
    Output(1, 1) = Target.Value
    Output(3, 1) = "No match found"
            
    Set Fnd = Rng.Find(What:=Target.Value, After:=Rng.Cells(Rng.Cells.Count), _
                       LookIn:=xlValues, LookAt:=xlPart, _
                       SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                       MatchCase:=False, SearchFormat:=False)
    If Not Fnd Is Nothing Then
        FirstFound = Fnd.Row
        Do
            ' collect all occurrences
            i = i + 1
            For C = 1 To ClmCount
                Output(C, i) = Ws.Cells(Fnd.Row, C).Value
            Next C
            
            Set Fnd = Rng.FindNext(Fnd)
            If Fnd Is Nothing Then Exit Do
        Loop While Fnd.Row > FirstFound
    End If
            
    Set Rng = Range(Target, Cells(Rows.Count, 1).End(xlUp))
    ' delete previous display
    If Rng.Row >= Target.Row Then Rng.Resize(, ClmCount).ClearContents

    If i = 0 Then i = 1
    ReDim Preserve Output(1 To ClmCount, 1 To i)
    
    ' prevent the next action from calling this procedure
    With Application
        .EnableEvents = False
        Target.Resize(UBound(Output, 2), UBound(Output)).Value = .Transpose(Output)
        .EnableEvents = True
    End With
End Sub