Karışık Yazılar İçerisindeki Mail Adreslerini Çıkarma

asam445 · 9 Ağustos 2017

Arkadaşlar, 500 satır var ve bunları arasında mail adresleri var. Mail adresleri ayrı hücrelerde ama tek tek sutun ve satır silerek yapmak uzun zaman alıyor. Bu mailleri kısa yolda bir yerde toplam şansımız var mı? Yardımcı olanlara şimdiden teşekkür ederim.

Ömer BARAN · 9 Ağustos 2017

Merhabalar.

Sorunuzu, bir örnek belge üzerinden sorarsanız daha hızlı sonuç alınır.

Örnek belgenin gerçek belgenizle aynı yapıda ve içerisindeki verilerin de
gerçek belgedeki verileri temsil edebilecek özellikte olmasına özen gösteriniz.

Örnek belge özellikleri ve örnek belge yükleme yöntemine ilişkin açıklama cevabımın altındaki İMZA bölümünde var.
.

cems · 9 Ağustos 2017

Örnek belge olmadığından deneme şansı yok ama şuradaki bilgi işinize yarayabilir

https://www.extendoffice.com/documents/excel/1272-excel-extract-email-address.html

asam445 · 9 Ağustos 2017

şu şekilde devam ediyor hocam örnek olarak. Bu şekilde devam ediyor.

Onayı Kaldır | Cevapla | Hızlı Düzenle | Düzenle | Geçmiş | İstenmeyen | Çöp
28.07.2017, 21:12
Yorumu seç
tu.......@yandex.com
78.173.58.236
serkan, evet bölgeniz için uygundur. çıktığı noktaya göre kargo firmaları değişiyor. Aras ve Yurtiçi kargo ile çalışıyoruz. Sipariş için buraya bakınız.

Onayı Kaldır | Cevapla | Hızlı Düzenle | Düzenle | Geçmiş | İstenmeyen | Çöp
25.07.2017, 23:47
Yorumu seç
se444444a@hotmail.com
85.108.184.45
Bulunduğum bölge Karaman’ın Toros dağları kısmı yükseklik 800-1300 arası mı sizce? Bir de hangi kargo şirketiyle çalışıyorsunuz.Bazıları bizim buralara gelmediği için soruyorum.Kolay gelsin.

Onayı Kaldır | Cevapla | Hızlı Düzenle | Düzenle | Geçmiş | İstenmeyen | Çöp
25.07.2017, 00:52
Yorumu seç
tu444444ak@yandex.com
78.171.15.235
D. ERSOY, ixxxxxx ile çalışabilirsiniz. Aynı ırkları aynı ortamda bulundurabilirsiniz herhangi bir sorun olmaz.

Ömer BARAN · 9 Ağustos 2017

Uzun uzun yazmak yerine birkaç satırlık gerçeğe benzer veri olan örnek belge yüklerseniz daha kolay sonuç alınır.
Örneğin veriler sütunlarda dağınık mıdır yoksa tümü A sütununda mıdır gibi belirsizlikler var.
.

Ömer BARAN · 9 Ağustos 2017

A1 hücresindeki metin için aşağıdaki formülü bir deneyin bakalım.
Sonuç alamazsanız mutlaka örnek belge yükleyin.
.

Kod:

=[COLOR="red"]PARÇAAL[/COLOR](A1;[COLOR="red"]BUL[/COLOR]("Yorumu seç";A1;1)+11;([COLOR="red"]BUL[/COLOR]("|";[COLOR="red"]YERİNEKOY[/COLOR](A1;[COLOR="red"]DAMGA[/COLOR](10);"|");[COLOR="red"]BUL[/COLOR]("@";A1;1)))-([COLOR="Red"]BUL[/COLOR]("Yorumu seç";A1;1)+11))

asam445 · 9 Ağustos 2017

Ömer BARAN' Alıntı:
Uzun uzun yazmak yerine birkaç satırlık gerçeğe benzer veri olan örnek belge yüklerseniz daha kolay sonuç alınır.
Örneğin veriler sütunlarda dağınık mıdır yoksa tümü A sütununda mıdır gibi belirsizlikler var.

kusura bakmayın hocam yükledim. http://dosya.co/32aukv18gi2p/örnekdosya.xlsx.html

cems · 9 Ağustos 2017

Kod:

Sub ExtractEmail()
'Update 20130829
Dim WorkRng As Range
Dim arr As Variant
Dim CharList As String
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
arr = WorkRng.Value
CheckStr = "[A-Za-z0-9._-]"
For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
        extractStr = arr(i, j)
        outStr = ""
        Index = 1
        Do While True
            Index1 = VBA.InStr(Index, extractStr, "@")
            getStr = ""
            If Index1 > 0 Then
                For p = Index1 - 1 To 1 Step -1
                    If Mid(extractStr, p, 1) Like CheckStr Then
                        getStr = Mid(extractStr, p, 1) & getStr
                    Else
                        Exit For
                    End If
                Next
                getStr = getStr & "@"
                For p = Index1 + 1 To Len(extractStr)
                    If Mid(extractStr, p, 1) Like CheckStr Then
                        getStr = getStr & Mid(extractStr, p, 1)
                    Else
                        Exit For
                    End If
                Next
                Index = Index1 + 1
                If outStr = "" Then
                    outStr = getStr
                Else
                    outStr = outStr & Chr(10) & getStr
                End If
            Else
                Exit Do
            End If
        Loop
        arr(i, j) = outStr
    Next
Next
WorkRng.Value = arr
ThisWorkbook.save
msg " Mail ayırma işlemi sona erdi "
End Sub

Dener misiniz ? biraz önce verdiğim sayfadan alıntıdır

asam445 · 9 Ağustos 2017

cems' Alıntı:

Kod:

Sub ExtractEmail()
'Update 20130829
Dim WorkRng As Range
Dim arr As Variant
Dim CharList As String
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
arr = WorkRng.Value
CheckStr = "[A-Za-z0-9._-]"
For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(arr, 2)
        extractStr = arr(i, j)
        outStr = ""
        Index = 1
        Do While True
            Index1 = VBA.InStr(Index, extractStr, "@")
            getStr = ""
            If Index1 > 0 Then
                For p = Index1 - 1 To 1 Step -1
                    If Mid(extractStr, p, 1) Like CheckStr Then
                        getStr = Mid(extractStr, p, 1) & getStr
                    Else
                        Exit For
                    End If
                Next
                getStr = getStr & "@"
                For p = Index1 + 1 To Len(extractStr)
                    If Mid(extractStr, p, 1) Like CheckStr Then
                        getStr = getStr & Mid(extractStr, p, 1)
                    Else
                        Exit For
                    End If
                Next
                Index = Index1 + 1
                If outStr = "" Then
                    outStr = getStr
                Else
                    outStr = outStr & Chr(10) & getStr
                End If
            Else
                Exit Do
            End If
        Loop
        arr(i, j) = outStr
    Next
Next
WorkRng.Value = arr
End Sub

Dener misiniz ? biraz önce verdiğim sayfadan alıntıdır

bu kodları nereye yapıştıracağız hocma.

cems · 9 Ağustos 2017

asam445' Alıntı:
bu kodları nereye yapıştıracağız hocma.

Ekteki dosyada vba kısmında yapıştırılmış durumda , sayfadaki tuşa basıp alan gösterin

Daha sonra vba kısmında solda modül içine bakın

Bu arada dikkat etmemişim , altın uye olmadığınızdan indiremezsiniz . Dış servera yukluyorum , link birazdan gorunecek

http://s6.dosya.tc/server10/uv3qos/nailleri_bul_.rar.html

Ömer BARAN · 9 Ağustos 2017

Tekrar merhaba.

Ben önceki cevabımda, e-posta adresinin metin içerisinde ve konumu değişken şekilde oduğunu varsaymıştım.

Örnek belgeye göre aşağıdaki şekilde sonuç alırsınız.
İkinci formüldeki mavi renklendirdiğim son satır numarasını gerçek belgedeki son veri satırının numarasıyla değiştirin.

-- B2 hücresine aşağıdaki formülü uygulayın ve aşağı doğru son veri satırına kadar kopyalayın.

Kod:

=[COLOR="red"]EĞER[/COLOR]([COLOR="red"]ESAYIYSA[/COLOR]([COLOR="red"]BUL[/COLOR]("@";A2;1));[COLOR="red"]MAK[/COLOR]($B$1:B1)+1;"")

-- C2 hücresine aşağıdaki formülü uygulayın ve BOŞ sonuç oluşuncaya kadar aşağı doğru kopyalayın.

Kod:

=[COLOR="red"]EĞER[/COLOR]([COLOR="red"]SATIR[/COLOR](A1)>[COLOR="Red"]MAK[/COLOR]($B$1:$B$[B][COLOR="Blue"][SIZE="4"]18[/SIZE][/COLOR][/B]);"";İNDİS($A$1:$A$[B][COLOR="Blue"][SIZE="4"]18[/SIZE][/COLOR][/B];[COLOR="Red"]KAÇINCI[/COLOR]([COLOR="Red"]SATIR[/COLOR](A1);$B$1:$B$[B][COLOR="Blue"][SIZE="4"]18[/SIZE][/COLOR][/B];0);0))

asam445 · 9 Ağustos 2017

cems' Alıntı:
Ekteki dosyada vba kısmında yapıştırılmış durumda , sayfadaki tuşa basıp alan gösterin

Daha sonra vba kısmında solda modül içine bakın

Bu arada dikkat etmemişim , altın uye olmadığınızdan indiremezsiniz . Dış servera yukluyorum , link birazdan gorunecek

http://s6.dosya.tc/server10/uv3qos/nailleri_bul_.rar.html

tamam hocam teşekürler oldu bu arada da altın üye oldum

cems · 9 Ağustos 2017

asam445' Alıntı:
tamam hocam teşekürler oldu bu arada da altın üye oldum

www.excel.web.tr bilgi paylaşma dünyasına hoşgeldiniz

Bu arada dipnot : benim hoca olmam için 39 fırın ekmek daha yemem lazım , şimdilik sitedeki hakkıyla " Omer Baran " gibi hocalar ortamında ; anca ayakta el bağlayarak duranlardan olabilirim

Ömer BARAN · 9 Ağustos 2017

Estağfurullah efendim, "hoca" yerine "tecrübeli"yi tercih ederim.

Bu arada Sayın asam445 benim cevabımı denedi mi, sonuç alabildi mi onu merak ediyorum.

-- İlk formül cevabım (6 numaralı cevap), "Onayı Kaldır" ibaresinden, bir sonraki aynı ibareye kadarki kısmın tek bir hücrede olduğunu varsayarak verilmişti,
-- ikinci cevabım (11 numaralı cevap) ise örnek belgedeki yapıya göre verilmişti.
.

Murat OSMA · 9 Ağustos 2017

Alternatif olarak bu dizi formülü de kullanılabilir.
Formülü B1 hücresine yazıp F2+CTRL+SHIFT+ENTER'a basarsınız.

Kod:

[SIZE="2"]=[COLOR="Red"]EĞERHATA[/COLOR]([COLOR="Navy"]İNDİS[/COLOR]($A$1:$A$21;[COLOR="Orange"]KÜÇÜK[/COLOR]([COLOR="Red"]EĞERHATA[/COLOR]([COLOR="Purple"]EĞER[/COLOR]([COLOR="DarkGreen"]BUL[/COLOR]("@";$A$1:$A$21)>0;[COLOR="Cyan"]SATIR[/COLOR]($A$1:$A$21));65536);[COLOR="cyan"]SATIR[/COLOR]()));"")[/SIZE]

cems · 9 Ağustos 2017

Bu sorunun alternatif çözümlerinde , sitede " yıldız değerinde hoca / deneyimli yağmuru" nun devam etmesi çok güzel bir bilgi değişim hissi oluşturuyor . Sayın asam445 , excel evreninin bu kozmik ama harika hadiselerine altın üyelğinizin daha başında tanık olun lutfen

Soran adına teşekkür ederim , Sayın OSMA

Karışık Yazılar İçerisindeki Mail Adreslerini Çıkarma

asam445

Ömer BARAN

Uzman

cems

asam445

Ömer BARAN

Uzman

Ömer BARAN

Uzman

asam445

cems

Ekli dosyalar

asam445

cems

Ömer BARAN

Uzman

asam445

cems

Ömer BARAN

Uzman

Murat OSMA

Altın Üye

cems