Adın ilk harfi ile soyadın tümünü seçmek

[ortim-03]

A sütununda yer alan bilgiler Ad Soyad şeklinde. ve bu ad soyaddan adın ilk harfi ile soyadın tamamını çekmek istiyorum. Yapmak istediğimi örneklersem sanırım daha kolay olacak. Elimde 600 kişilik bir personel listesi var. Bu listade maalesef ad soyad aynı hücrede. Bu listedeki kişilere bir kurumsal e-mail adresi vermem gerekiyor ve bu adın ilk harfi ve soyad şeklinde olacak. Adın ilk harfini almakta sorun yok ama soyadını alamadım. Kaldı ki çift isimlerde de sorunum var.

Ad Mail
Mehmet ÇELİKKAYA mcelikkaya@xxx.xxx
Ali Rıza Duran arduran@xxx.xxx

bunu nasıl yapabilirim? Muhtemel yardımlarınız için Teşekkür ederim.

 

[Civan Jack]

Çift isim ve çift soyisim kullanan kişiler olabiliyor.
Örnek dosyanızı görelim.

 

[Civan Jack]

Şu kodları bir deneyin;

Sub E_Posta_Yap()
    Dim i As Integer
    Dim c As Variant
    On Error Resume Next
    For i = 1 To Range("A65536").End(3).Row
        For a = 0 To 3
            c = Split(Cells(i, 1), " ")
            Cells(i, 2) = VBA.Left(Cells(i, 1), 1) & c(a) & "@xxx.xxx"
        Next a
    Next i
    i = Empty: c = Empty
End Sub

 

[ortim-03]

Üstad Teşekkürler. Şimdilik işimi görmekle beraber çift isimlerde sorun var. Yalnız İlk isim ve soyadı birleştiriyor. Eğer uğraştıracaksa manuel de yapabilirim. Allah razı olsun...

 

[Civan Jack]

Kodlardan kaynaklı bir sorun olacağını sanmıyorum. Olursa da dosyanızı ekleyin bakalım.

 

[ortim-03]

Üstad verdiğiniz örnek dosyada da durum aynı. Örneğin;
portakal mandalina visne pmvisne@xxx.xxx olmalı. yani sorun çift isimlerde. Sorun benim eksik anlatımımdan da kaynaklanıyor olabilir. Verdiğim zahmet için özür dilerim.

 

[Necdet]

Merhaba,

Bir denemede benden.

N2 hücresine @ olmadan uzantıyı girebilirsiniz. Ayrıca küçük ve ingilizce harflerine dönüştürülür.

Sub emailOlustur()
 
    Dim i   As Integer
    Dim j   As Integer
    Dim ad  As String
    Dim s
 
    Application.ScreenUpdating = False
    Range("b:b").ClearContents
 
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        ad = Application.WorksheetFunction.Trim(Cells(i, "A"))
        ad = Evaluate("=LOWER(" & """" & ad & """" & ")")
        ad = Replace(Replace(Replace(Replace(Replace(Replace(ad, "ç", "c"), "ğ", "g"), "ı", "i"), "ö", "o"), "ş", "s"), "ü", "u")
 
        s = Split(ad, " ")
        ad = ""
 
        For j = 0 To UBound(s)
            If j < UBound(s) Then
                ad = ad & Left(s(j), 1)
            Else
                ad = ad & s(j)
            End If
        Next j
 
        ad = WorksheetFunction.Trim(ad) & "@" & Range("N2")
        Cells(i, "B") = ad
    Next i
 
    Application.ScreenUpdating = True
 
    MsgBox "e-mail OLUŞTURULMUŞTUR...", vbInformation, "Excel.web.tr"
 
End Sub

 

[ortim-03]

Üstad harika. Çözüm budur. Çözüm üretmek için çabalayan herkese müteşekkirim. Allah Razı Olsun...

 

[Necdet]

Üstad harika. Çözüm budur. Çözüm üretmek için çabalayan herkese müteşekkirim. Allah Razı Olsun...

Merhaba,

Üstad ben mi oluyorum? o mertebeye gelmek için daha uzun yolumuz var:redface:

 

[ortim-03]

Benden 1 fazla biliyorsanız benim üstadımsınız. k::