Поиск и выборка по листу excel

Sub ppp()
kk = 1
For Each ccc In Sheets(1)
If InStr(ccc.Text, "@") > 0 Then
Sheets(2).Cells(kk, 1) = ccc.Text
kk = kk + 1
End If
End Sub

Sub ppp()
  kk = 1
  For Each ccc In Sheets(1)
       If InStr(ccc.Text, "@") > 0 Then
          Sheets(2).Cells(kk, 1) = ccc.Text
          kk = kk + 1
       End If
  Next
End Sub

Sub ppp()
    Dim ccc As Range, kk As Long
 
    kk = 1
    For Each ccc In Sheets("Лист1").UsedRange
        If InStr(ccc.Text, "@") > 0 Then
            Sheets("Лист2").Cells(kk, 1) = ccc.Text
            kk = kk + 1
        End If
    Next
    MsgBox "Конец", vbInformation, ""
End Sub

Sub ppp()
  kk = 1
  For Each ccc In Sheets(1).Cells
       If InStr(ccc.Text, "@") > 0 Then
          Sheets(2).Cells(kk, 1) = ccc.Text
          kk = kk + 1
       End If
  Next
End Sub

For Each ccc In Sheets(1)

For Each ccc In Sheets(1).Cells

Function em(S As String)
    Dim v
    Dim EML_PTRN$
    EML_PTRN = "[A-Z0-9._%-]+@[A-Z0-9.-]+\.[A-Z]{2,4}"
 
    With CreateObject("vbscript.regexp")
        .Pattern = EML_PTRN
        .Global = True
        .IgnoreCase = True
        Set v = .Execute(S)
    End With
    em = v(0).Value
End Function

Option Explicit
 
Sub ppp()
    Dim Rng As Range
 
    With Sheets("Лист1")
        Set Rng = Intersect(.UsedRange, .Columns(4))
    End With
 
    EmailsExtract Rng, Sheets("Лист2").Range("A1")
    
    MsgBox "Конец", vbInformation, ""
End Sub
 
' ZVI:2011-05-27 [url]http://www.planetaexcel.ru/forum.php?thread_id=28292[/url]
' Выдает массив e-mails из смешанного текста Txt
Function EmailsArray(Txt)
    If InStr(Txt, "@") = 0 Then Exit Function
    Dim s$, x, a, i&
    s = Txt
    If InStr(s, vbLf) Then s = Replace(s, vbLf, " ")
    If InStr(s, vbCr) Then s = Replace(s, vbCr, " ")
    If InStr(s, ",") Then s = Replace(s, ",", " ")
    If InStr(s, " @ ") Then s = Replace(s, " @ ", "@")
    a = Split(s)
    For Each x In a
        If Len(x) > 4 Then
            If InStr(x, "@") Then
                a(i) = x
                i = i + 1
            End If
        End If
    Next
    If i Then
        ReDim Preserve a(i - 1)
        EmailsArray = a
    End If
End Function
 
' ZVI:2011-05-27 [url]http://www.planetaexcel.ru/forum.php?thread_id=28292[/url]
' Процедура извлечения уникальных e-mails из RngFrom и копирования в TopCellTo
' Пример вызова: EmailsExtract Range("A:A"), Range("C2")
Sub EmailsExtract(ByVal RngFrom As Range, TopCellTo As Range)
    Dim a, b(), e, i&, j&, x
    Set RngFrom = Intersect(RngFrom, RngFrom.Parent.UsedRange)
    With TopCellTo.Parent.UsedRange
        j = .Rows.Count - .Row + 1
        If j < 0 Then j = 1
    End With
    ReDim b(1 To TopCellTo.Parent.Rows.Count, 1 To 1)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each x In RngFrom.Value
            a = EmailsArray(x)
            If IsArray(a) Then
                For Each e In a
                    If Not .Exists(e) Then
                        i = i + 1
                        b(i, 1) = e
                        .Item(e) = 0
                    End If
                Next
            End If
        Next
    End With
    With TopCellTo.Resize(i, 1)
        With .Parent.UsedRange
            j = .Rows.Count - .Row + 1
        End With
        If j > .Row Then .Resize(j - .Row + 1, 1).ClearContents
        If i Then
            .Value = b()
            .Sort .Cells(1, 1), xlAscending, Header:=xlNo
        End If
    End With
End Sub