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

Question

I have a file that I use as a phone book, In column A and B have surnames and names while in column C have the landline number and in D the mobile number. Doing the search if the fixed number is not present in column C, it does not even show me the mobile phone, is it possible to correct this error? Thank you

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

For this solution I created a worksheet with a validation dropdown in cell B2 allowing the choice of "Name" or "Surname". I also entered the text "Find Contact" in A2 as a caption to the cell A3 which is blank. All rows below A3 are also blank.

Observe that the cells A3 and B2 are referred to in the code by name. You can transfer their functionality to any other cells on the same worksheet by changing the values of the constants in the code. You can also change the number of columns there (4 for now, as you have specified) and the name of the worksheet containing your phone list ( Worksheets("Sheet4") for now) as well as the syntax by which it is specified.

The ActiveSheet is specified by the location of the code. Paste it to the code sheet of the worksheet your code identifies as Sheets(1) . This location is of critical importance. If you paste the code to a standard code module (with a name like Module1 ) it will lose its automation capabilities.

Properly installed, it will react to a change in A3 as well as B2. Say, you have selected "Surname" in B2 and enter "Mike" in A3 the code will list all matches with their numbers in A3:D3 and down, to a maximum of 20 (which you can de- or increase in the code). However, "Mike" isn't a surname. Therefore the code may return "No match found". You can now change the search field selector in B2 to "Name". That will cause the code to look for "Mike" in the other column and list all Mikes found. No need to enter the search criterium again.

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