Find komutunda hata

[vivident]

Merhaba

"A" shettinde "@" karakterine sahip hücreleri bulup kopyalacak ve (mail adreslerini buldurma) "B" sayfasının A1 hücresinden başlayarak alt alta yapıştırması gerekiyor.

Sub deneme()
With Worksheets("A").Range("A1:E500")
Cells.Find("@", LookIn:=xlValues).Select
ActiveCell.Copy
Sheets("B").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End With
End Sub

Dosya ektedir

 

[Korhan Ayhan]

Deneyiniz.

Sub Mail_Bul()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Bul As Range, Adres As String
    
    Set S1 = Sheets("A")
    Set S2 = Sheets("B")
    S2.Range("A:A").ClearContents
    Satır = 1
    
    Set Bul = S1.Range("A1:E500").Find("@", LookIn:=xlValues)
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            S2.Range("A" & Satır) = Bul.Value
            Satır = Satır + 1
            Set Bul = S1.Range("A1:E500").FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If

    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[vivident]

Süpersiniz, elinize sağlık