Tek hücre içinden istenilen karaktere sahip birden çok veriyi çekmek

[CENGAVER1]

Merhaba,
Basit komutlarla vba kullanıyorum ancak bu işlem benim makro bilgimin çok ilerisinde olduğundan yardımınıza ihtiyaç duyuyorum. Böyle bir konu bulamadım, eğer varsa konuyu refere etseniz de yeterli olur

şirketiminizin mail adreslerinin çektiğimde tek bir hücrede yüzlerce mail adresi geliyor.

Örnek: ESAT KATIK (IT Dept. (Veri Md.(DATA)) - Analist(DATA)) <ESATK@LEGO.COM>; LEVENT KURTBAY (IT Dept. (Veri Md.(DATA)) - Analist(DATA)) <LKURTBAY@LEGO.COM>; MURAT GOKYAR (IT Dept. (Veri Md.(DATA)) - Analist(DATA)) <MURATG@LEGO.COM>; ONEM SAYER (IT Dept. - Tip Muduru(DATA)) <OSAYER@LEGO.COM>; SERKAN AKINCI (IT Dept. (Veri Md.(DATA)) - Analist(DATA)) <SAKINCI@LEGO.COM>; TUGBERK INANC (IT Dept. (Veri Md.(DATA)) - Analist(DATA)) <TINANC@LEGO.COM>; NOLAN BASAR (IT Dept. (Veri Md.(DATA)) - Analist(DATA)) <NBASAR@LEGO.COM>

Bunu içindeki @ karakterine sahip kelimeyi kopyalayarak, veya <ile başlayan her ifadeyi > karakterine kadar kopyalayarak yapabileceğimizi düşündüm. Ancak yapamadım
Bu datanın hepsi A1 hücresinde ise her mail adresini çekerek sırayla B1-B2-B3 şeklinde ne kadar varsa yazdırabilir miyiz acaba?

Yardımcı olabilirseniz minnettar olurum.
Saygılarımla

 

[Haluk]

Makrosuz çözüm isterseniz;

-A sütununu seçin,
-Data > Text to Columns
-Delimited - Next
-Semicolon'u işaretleyin
-Finish

.

B, C, D .... hücrelerinde ayrıştırılmış olarak göreceksiniz.

Düzeltme: Soruyu eksik cevaplamışım. Yukarıdaki önerim sadece e-posta adreslerini değil, ";" ile ayrılmış kısımları bütün olarak alır.

.

 

[CENGAVER1]

Haluk bey, cevabınız için teşekkürler,
Şu an zaten manuel kolonlara ayırıp, formüllerle mailleri alıp, başka listelerle kıyaslayarak kontrol sağlıyoruz.Ve bunu 8-10 liste için yapıyoruz
Eğer makronun sorduğum kısmını çözebilirsem diğer kısımlarla birlikte tek bir tuşla tüm işlemleri yaptırmayı düşündük.

 

[Haluk]

O zaman aşağıdaki makroyu deneyin.

A1 hücresindeki dataları B sütununda alt alta ayrıştırıp, sıralar.

Sub Test()
    Dim arrayData As Variant
    arrayData = Split(Range("A1"), ";")
    For Each Data In arrayData
        strTemp = arrayData(i)
        strAnchor = InStr(1, strTemp, "<")
        strMailAddress = Left(Mid(strTemp, strAnchor + 1, 99), Len(Mid(strTemp, strAnchor + 1, 99)) - 1)
        Range("B" & i + 1) = strMailAddress
        i = i + 1
    Next
End Sub

 

[Haluk]

@CENGAVER1;

Yukarıdaki kod işinize yaradı mı?

.

 

[CENGAVER1]

Haluk bey,
Kod harika çalıştı teşekkürler,
370 maillik bir listeyi kopyaladım 326 yı sorunsuz aktardı
diğerlerini aktarmama sebebi de kalanları alt satıra atmış
Sanırım hücrenin 32,767 karakter sayısını geçtiği için.

Eğer 2.satırda da aynı işlemi yapıp önceki yaptıklarının üzerine devam edebilir miyiz dersem çok uğraştırır mı sizi acaba?

 

[Haluk]

Merhaba;
Su anda bilgisayar basinda degilim, aksama dogru ancak kodu revize edebilirim.
Selamlar,

.

 

[CENGAVER1]

Haluk bey hiç sorun değil, şu yaptığınız bile acayip işime yaradı.
Birleştirme için işinize yarar diye son kayıtların görüntüsünü de ekliyorum.
Saygılarımla

https://ibb.co/bxSXuG

 

[Haluk]

Tekrar merhaba;

A1 ve altındaki diğer hücreler için de işlem yapılması için, aşağıdaki kodu deneyebilirsiniz.

Sub Test2()
    Dim arrayData As Variant
    NoA = Cells(Rows.Count, 1).End(xlUp).Row
    For j = 1 To NoA
        arrayData = Split(Range("A" & j), ";")
        i = 0
        For Each Data In arrayData
            strTemp = arrayData(i)
            strAnchor = InStr(1, strTemp, "<")
            strMailAddress = Left(Mid(strTemp, strAnchor + 1, 99), Len(Mid(strTemp, strAnchor + 1, 99)) - 1)
            Range("B" & r + 1) = strMailAddress
            i = i + 1
            r = r + 1
        Next
    Next
    Erase arrayData
End Sub

 

[CENGAVER1]

Haluk bey harika çalışıyor ancak ufak bir bug var birleşim noktasında
ilk hücrenin sonundaki kişinin kalan datatısnı da maillerin arasına bir satır yaparak koyuyor
sonra aynı kişinin mailiyle devam ediyor bir alt satırdan ekteki gibi

https://ibb.co/eUZgpG

 

[Haluk]

Merhaba;

Onu yapmasını gerektirecek bir kod yok.

Siz "B" sütununu manuel olarak komple silip, kodu bir daha çalıştırın. Bakalım aynı şey olacak mı?

.

 

[CENGAVER1]

yapıyor hocam,
sanırım son ; den sonraki kısımı hafızaya alıyor, içinde <> bulamayınca hafızadaki datayı yazıyor.
mail kısmı a2 de kaldığı için yukarıdaki son datanın mailinden başlayarak devam ediyor.
2.yüklediğim görselin aynısı oluyor

 

[Haluk]

Sorun; muhtemelen 12 No'lu mesajınızda belirttiğiniz gibi hücrelerdeki verilerin bütün olarak yerleştirilememesinden kaynaklanıyor.

O zaman, kodlarda bir kontrol daha ilave ederek sorunu çözebiliriz diye düşünüyorum.

Bu nedenle, bir de aşağıdaki kodu denemenizi öneririm...

Sub Test3()
    Dim arrayData As Variant
    NoA = Cells(Rows.Count, 1).End(xlUp).Row
    For j = 1 To NoA
        arrayData = Split(Range("A" & j), ";")
        i = 0
        For Each Data In arrayData
            strTemp = arrayData(i)
            strAnchor = InStr(1, strTemp, "<")
            strMailAddress = Left(Mid(strTemp, strAnchor + 1, 99), Len(Mid(strTemp, strAnchor + 1, 99)) - 1)
            If InStr(1, strMailAddress, "@") Then
                Range("B" & r + 1) = strMailAddress
                i = i + 1
                r = r + 1
            End If
        Next
    Next
    Erase arrayData
End Sub

 

[CENGAVER1]

Haluk bey,
ancak bakabildim kusura bakmayın, kod kusursuz bir şekilde çalışıyor,
devamında yapması gereken şeyleri ben kendi giriş seviyesi vba bilgimle yapmaya çalışacağım inşallah, sizin en çok zorlandığım bu kısımda bana yardımınız için gerçekten minnettarım.
Size nasıl teşekkür edebilirim?

 

[Haluk]

Rica ederim, kolay gelsin....

.