使用空白中間單元格復制粘貼整行

Question

我有一個用作電話簿的文件，在 A 和 B 列中有姓氏和姓名，而在 C 列中有固定電話號碼，在 D 中有手機號碼。 如果C列中沒有固定號碼進行搜索，它甚至不顯示手機，是否可以更正此錯誤？ 謝謝

Set intervallo = Sheets(4).Range("A2", Sheets(4).Range("A1").End(xlDown)) ``
For Each Cognome In intervallo ``
If Cognome Like Sheets(1).Ricerca & "*" ``
Sheets(4).Range(Cognome, Cognome.End(xlToRight)).Copy ``
Sheets(1).Range("A" & (Rows.Count)).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues ``

Answer 1

對於此解決方案，我在單元格 B2 中創建了一個帶有驗證下拉列表的工作表，允許選擇“姓名”或“姓氏”。 我還在 A2 中輸入了文本“查找聯系人”作為空白單元格 A3 的標題。 A3 以下的所有行也是空白的。

請注意，代碼中按名稱引用了單元格 A3 和 B2。 您可以通過更改代碼中常量的值將它們的功能轉移到同一工作表上的任何其他單元格。 您還可以更改其中的列數（現在為 4，如您所指定）和包含電話列表的工作表的名稱Worksheets("Sheet4")現在為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