Cümle içinden e-mail adreslerini almak

[By_AbbA]

Mustafa (by_abba@hotmail.com);
musti01977@hotmail.com (musti01977@hotmail.com);
müslüman (cihadi-ekber@hotmail.com);
Nuray (nuraydogan24@hotmail.com);

A sütünün listesi ve liste uzayıp gidiyor. Burada benim yapmak istedigim şey şu () arasında kalan email adreslerini almak. parantezler dahil, diger kısımların silinmesi gerekiyor. bunun niçin nasıl kodlama gerekiyor.
Yardımcı olan arkadaşlara şimdiden teşekkürler...

 

[Kemal Demir]

İyi akşamlar,

Sub SıfırlamaYap()
For x = 2 To [a65536].End(3).Row
uzunluk = Len(Cells(x, 1))
For k = 1 To uzunluk
If Left(Cells(x, 1), 1) = "(" Then
Else
Cells(x, 1) = Right(Cells(x, 1), uzunluk - k)
End If
say = Len(Cells(x, 1)) - 1
If Right(Cells(x, 1), 1) = ";" Then
Cells(x, 1) = Left(Cells(x, 1), say)
End If

Next
Next

End Sub

Yukarıdaki kod zannedersem işinizi görür.

 

[By_AbbA]

Kemal teşekkür ederim. Kırmızı ile yazılmış yeri 1 yaptıgımızda A1 hücresinden başlayıp tüm parantez dışında kalan kısımları gayet güzel siliyor.

Biraz daha kafa yorsak ( ve ) sildirmemizin bir yolu varmı?

Sub SıfırlamaYap()
For x = 1 To [a65536].End(3).Row
uzunluk = Len(Cells(x, 1))
For k = 1 To uzunluk
If Left(Cells(x, 1), 1) = "(" Then
Else
Cells(x, 1) = Right(Cells(x, 1), uzunluk - k)
End If
say = Len(Cells(x, 1)) - 1
If Right(Cells(x, 1), 1) = ";" Then
Cells(x, 1) = Left(Cells(x, 1), say)
End If

Next
Next

End Sub

 

[tahsinanarat]

Sub ayir()
On Error Resume Next
Dim sonsat As Long, i As Long, ilk As Byte, son As Byte, uzunluk As Byte
sonsat = Sheets("Sayfa1").Cells(65536, "A").End(xlUp).Row
For i = 1 To sonsat
ilk = WorksheetFunction.Find("(", Cells(i, "A").Value) + 1
son = WorksheetFunction.Find(")", Cells(i, "A").Value)
uzunluk = son - ilk
sonuc = Mid(Cells(i, "A").Value, ilk, uzunluk)
Cells(i, "A").Value = sonuc
Next
End Sub


Cells(i, "A").Value = sonuc satırındaki "A" harfini "B" yaparsan ayıklanmış halini B sutununa atar.
Kolay gelsin.

 

[By_AbbA]

Süper bir makro...:hihoho:
Çok teşekkür ettim.

 

[Kemal Demir]

tahsinararat,

Gayet başarılı bir çalışma.Aklıma gelmemişti.Tekrar tebrikler.

Yukarıdaki kod'un yanına başkabir kod yazmak biraz abest kaçar.

 

[Ali]

Buda formüllü olsun.

Alternatif1

B1 hücresine

=PARÇAAL(A1;BUL("(";A1)+1;TOPLA(BUL({"(";")"};A1)*{-1;1})-1)

yazıp aşağı doğru çekiniz.

Alternatif2

=YERİNEKOY(DEĞİŞTİR(A1;1;MBUL("(";A1);"");");";"")

 

[Ali]

Buda kullanıcı tanımlı fonksiyon

Function email(txt As String) As String
With CreateObject("VBScript.RegExp")
.Pattern = "[a-z0-9][a-z0-9_\.\-]+@[a-z0-9\-\.]+(\.[a-z]{2,3})+"
.IgnoreCase = True
If .test(txt) Then email = .Execute(txt)(0)
End With
End Function

 

[BirTürk1]

Hücrede 00-1c-26-9c-6f-2c şeklinde veri var bunu - işaretinden kurtarmak için bu kodlardan yararlanabilirmiyiz

not : 00-1c-26-9c-6f-2c bu veriler MAC adresi

 

[hsayar]

Hücrede 00-1c-26-9c-6f-2c şeklinde veri var bunu - işaretinden kurtarmak için bu kodlardan yararlanabilirmiyiz

not : 00-1c-26-9c-6f-2c bu veriler MAC adresi

Dim hcr As Range, sonsat as long, i as long
......
sonsat = Sheets("Sayfa1").Cells(65536, "[COLOR=Red]A[/COLOR]").End(xlUp).Row
For i = 2 to sonsat
  Set hcr = Range("[COLOR=Red]A[/COLOR]:" & i)
  hcr = replace(hcr,"-","")
NEXt i 
set hcr = nothing
........

şeklinde kullanabilirsiniz

 

[Kemal Demir]

Ali Bey ve hsayar,

Alternatif çözümler çok iyi.Benim içinde güzel bir örnek oldu.

Teşekkurler arkadaşlar.

 

[BirTürk1]

Teşekkür ederim sayın sayar

şimdi denedim fakat kod hata veriyor çalışmayı durduruyor

 

[Ali]

A sütunun seçin CTRL+H tuşuna basın

Üstteki kısıma -
Alttaki kısıma birşey yazmayıp tümünü değiştiri tıklayınız.

 

[hsayar]

Teşekkür ederim sayın sayar

şimdi denedim fakat kod hata veriyor çalışmayı durduruyor

sub tireleri_sil()
Dim hcr As Range, sonsat as long, i as long
......
'A : Tireler hangi sütunda ise ona göre düzeltiniz.

sonsat = Cells(65536, "[COLOR=Red]A[/COLOR]").End(xlUp).Row
For i = 2 to sonsat
  Set hcr = Range("[COLOR=Red]A[/COLOR]:" & i)
  hcr = replace(hcr,"-","")
NEXt i 
set hcr = nothing
........end sub

olmadı örnek dosya ekleyiniz.

 

[BirTürk1]

Yine yapamadım

dosyayı ekliyorum

 

[Ali]

=B1&"5711097756"&D1

şeklindeki formülü

=YERİNEKOY(B1;"-";"")&C1&D1

şeklinde kullanın.

 

[hsayar]

Yine yapamadım

dosyayı ekliyorum

Sub tireleri_sil()
'A(1) ve I(9) sütunlarında bulunan verilerin içinde tireleri siler.
Dim hcr As Range, sonsat As Long, i As Long
For sutun = 1 To 9
sonsat = Cells(65536, sutun).End(xlUp).Row
  For satır = 1 To sonsat
    Set hcr = Cells(satır, sutun)
    hcr = Replace(hcr, "-", "")
  Next satır
Next sutun
Set hcr = Nothing
End Sub

 

[BirTürk1]

teşekkür ederim yerini buldu