Ad ve Soyadların ilk-son harflerini bırakıp aradaki karakter sayısınca * ile değiştirmek

[merrrakli]

Başlıkta da belirttliğim gibi Ad ve Soydaların ilk-son harflerini bırakıp aradaki karakter sayısınca * ile nasıl değiştirebiliriz?

 

[Asri]

Formül işlerinden pek anlamam.
D1 e yapıştırıp aşağı çekin.

İki isimli şahıslarda 2. ismi dikkate almaz.

=LEFT(C1;1) & REPT("*";LEN(MID(C1;1;SEARCH(" ";C1;1)-1))-2) & MID(C1;SEARCH(" ";C1;1)-1;1) & " " & IF(ISERR(SEARCH(" ";MID(C1;SEARCH(" ";C1;1)+1;LEN(C1))));LEFT(MID(C1;SEARCH(" ";C1;1)+1;LEN(C1));1) & REPT("*";LEN(MID(C1;SEARCH(" ";C1;1)+1;LEN(C1)))-2) & RIGHT(C1;1);LEFT(MID(C1;SEARCH(" ";C1;SEARCH(" ";C1;1)+1)+1;LEN(C1));1) & REPT("*";LEN(MID(C1;SEARCH(" ";C1;SEARCH(" ";C1;1)+1);LEN(C1)))-2) & RIGHT(C1;1))

Türkçe office kullanmıyorum. Ancak formül çeviri programım aşağıdaki şekilde çevirdi.
Büyük ihtimal ile uyacaktır. Belki ; leri , yapmak gerekebilir.

'=SOLDAN(C1;1) & YİNELE("*";UZUNLUK(PARÇAAL(C1;1;MBUL(" ";C1;1)-1))-2) & PARÇAAL(C1;MBUL(" ";C1;1)-1;1) & " " & EĞER(EHATA(MBUL(" ";PARÇAAL(C1;MBUL(" ";C1;1)+1;UZUNLUK(C1))));SOLDAN(PARÇAAL(C1;MBUL(" ";C1;1)+1;UZUNLUK(C1));1) & YİNELE("*";UZUNLUK(PARÇAAL(C1;MBUL(" ";C1;1)+1;UZUNLUK(C1)))-2) & SAĞDAN(C1;1);SOLDAN(PARÇAAL(C1;MBUL(" ";C1;MBUL(" ";C1;1)+1)+1;UZUNLUK(C1));1) & YİNELE("*";UZUNLUK(PARÇAAL(C1;MBUL(" ";C1;MBUL(" ";C1;1)+1);UZUNLUK(C1)))-2) & SAĞDAN(C1;1))

 

[Utekiner]

@Asri Bey makro ile nasıl yapabiliriz.

 

[muratboz06]

Herhangi bir module oluşturarak aşağıdaki kodları ekleyiniz.
Çalışma sayfasında =YILDIZYAP(A1) yazarsanız A1 hücresindeki ismi yıldızlı yapar. Formülü aşağı doğru kopyalarsınız.

Function YILDIZYAP(X As Range) As String

    If X.Cells.Count = 1 Then
        Dim isimler() As String
        Dim i As Byte, j As Byte, k As Byte
        
        isimler = Split(X.value)
        For i = LBound(isimler) To UBound(isimler)
            j = Len(isimler(i)) - 1
            isimler(i) = Left(isimler(i), 1)
            For k = 1 To j
                isimler(i) = isimler(i) & "*"
            Next k
            YILDIZYAP = YILDIZYAP & " " & isimler(i)
        Next i
       Else
        MsgBox "Sadece bir hücre seçiniz."
    End If
    
End Function

 

[merrrakli]

Teşekkür ederim.
Formül çeviri programı dediğiniz hangisidir. İncelemek isterim.

Formül işlerinden pek anlamam.
D1 e yapıştırıp aşağı çekin.

İki isimli şahıslarda 2. ismi dikkate almaz.

=LEFT(C1;1) & REPT("*";LEN(MID(C1;1;SEARCH(" ";C1;1)-1))-2) & MID(C1;SEARCH(" ";C1;1)-1;1) & " " & IF(ISERR(SEARCH(" ";MID(C1;SEARCH(" ";C1;1)+1;LEN(C1))));LEFT(MID(C1;SEARCH(" ";C1;1)+1;LEN(C1));1) & REPT("*";LEN(MID(C1;SEARCH(" ";C1;1)+1;LEN(C1)))-2) & RIGHT(C1;1);LEFT(MID(C1;SEARCH(" ";C1;SEARCH(" ";C1;1)+1)+1;LEN(C1));1) & REPT("*";LEN(MID(C1;SEARCH(" ";C1;SEARCH(" ";C1;1)+1);LEN(C1)))-2) & RIGHT(C1;1))

Türkçe office kullanmıyorum. Ancak formül çeviri programım aşağıdaki şekilde çevirdi.
Büyük ihtimal ile uyacaktır. Belki ; leri , yapmak gerekebilir.

'=SOLDAN(C1;1) & YİNELE("*";UZUNLUK(PARÇAAL(C1;1;MBUL(" ";C1;1)-1))-2) & PARÇAAL(C1;MBUL(" ";C1;1)-1;1) & " " & EĞER(EHATA(MBUL(" ";PARÇAAL(C1;MBUL(" ";C1;1)+1;UZUNLUK(C1))));SOLDAN(PARÇAAL(C1;MBUL(" ";C1;1)+1;UZUNLUK(C1));1) & YİNELE("*";UZUNLUK(PARÇAAL(C1;MBUL(" ";C1;1)+1;UZUNLUK(C1)))-2) & SAĞDAN(C1;1);SOLDAN(PARÇAAL(C1;MBUL(" ";C1;MBUL(" ";C1;1)+1)+1;UZUNLUK(C1));1) & YİNELE("*";UZUNLUK(PARÇAAL(C1;MBUL(" ";C1;MBUL(" ";C1;1)+1);UZUNLUK(C1)))-2) & SAĞDAN(C1;1))

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sub Yıldız_Yap()

    Dim i   As Long, _
        j   As Integer
        
    Application.ScreenUpdating = False
    
    For i = 1 To Cells(Rows.Count, "A").End(3).Row
    
        Cells(i, "B") = Cells(i, "A")
        
        For j = 2 To Len(Cells(i, "A")) - 1
            If Mid(Cells(i, "B"), j, 1) = " " Then j = j + 2
            If Not j = Len(Cells(i, "A")) Then
                If Mid(Cells(i, "B"), j + 1, 1) <> " " And Mid(Cells(i, "B"), j, 1) <> " " Then Range("B" & i).Characters(j, 1).Insert "*"
            End If
        Next j
                
    Next i
       
    Application.ScreenUpdating = True
    
End Sub

 

[Asri]

Teşekkür ederim.
Formül çeviri programı dediğiniz hangisidir. İncelemek isterim.

Özel geliştirdiğim bir program olduğu için ücretsiz değil ve kodları açık değil.

http://asriakdeniz.com/excel-ozel-islemler-menusu/

 

[Asri]

@Asri Bey makro ile nasıl yapabiliriz.

Alternatif;

Biri fonksiyon diğeri döngü. Kelime sınırı yoktur. Bir den fazla ismi destekler.

Function YILDIZLA(veristr As Range) As String
    veri = Trim(veristr.Value)
    For j = 2 To Len(veri) - 1
        If Mid(veri, j - 1, 1) <> " " And Mid(veri, j + 1, 1) <> " " And Mid(veri, j, 1) <> " " Then
           Mid(veri, j, 1) = "*"
        End If
    Next j
    YILDIZLA = veri
End Function

Sub yildizla_dongu()
   For i = 1 To Cells(Rows.Count, "A").End(3).Row
       veri = Trim(Cells(i, "A").Value)
       For j = 2 To Len(veri) - 1
           If Mid(veri, j - 1, 1) <> " " And Mid(veri, j + 1, 1) <> " " And Mid(veri, j, 1) <> " " Then
              Mid(veri, j, 1) = "*"
           End If
       Next j
       Cells(i, "B").Value = veri
    Next i
End Sub

 

[Korhan Ayhan]

Alternatif;

KTF (Kullanıcı tanımlı Fonksiyon);

=KODLA(Hücre_Adresi;Karakter;Kriter)

Fonksiyondaki "Karakter" bölümü opsiyoneldir.

Varsayılan olarak yıldız karakteri tanımlıdır. Karakter bölümünü belirtmezseniz otomatik olarak yıldız eklenir. Kendiniz farlı karakter kullanabilirsiniz.

Fonksiyondaki "Kriter" bölümü opsiyoneldir.

0 ya da boş bırakırsanız Elif DENİZ ismi (E*** D**** olarak görünür)
1 yazarsanız Elif DENİZ ismi (E**f D***Z olarak görünür)

Option Explicit

Function KODLA(Veri As Variant, Optional Karakter As String = "*", Optional Kriter As Byte = 0)
    Dim Kelime As Variant, X As Byte, Metin As String, Say As Byte
    
    Application.Volatile True
    
    If IsNumeric(Veri) Then
        KODLA = Veri
        Exit Function
    End If
    
    If Kriter = 0 Then
        With CreateObject("VBScript.RegExp")
            .Pattern = "[a-zçıiğöşü]"
            .Global = True
            KODLA = .Replace(Application.Proper(WorksheetFunction.Trim(Veri)), Karakter)
        End With
    ElseIf Kriter = 1 Then
        ReDim Dizi(1 To 1)
        Kelime = Split(WorksheetFunction.Trim(Veri), " ")
        For X = 0 To UBound(Kelime)
            Say = Say + 1
            ReDim Preserve Dizi(1 To Say)
            If Len(Kelime(X)) > 2 Then
                Metin = Mid(Kelime(X), 2, Len(Kelime(X)) - 2)
                Metin = String(Len(Metin), Karakter)
                Dizi(Say) = Left(Kelime(X), 1) & Metin & Right(Kelime(X), 1)
            Else
                Dizi(Say) = Kelime(X)
            End If
        Next
        KODLA = Join(Dizi, " ")
    Else
        KODLA = "Uygun parametre giriniz!"
    End If
End Function

 

[Asri]

@Korhan Ayhan ın yöntemini sevdim. Fonksiyona eklendi.
Aynı koşul geçerlidir.

Function YILDIZLA(veristr As Range, Optional kriter As Byte = 0) As String
    veri = Trim(veristr.Value)
    For j = 2 To Len(veri) - 1
        If kriter = 0 Then
            If Mid(veri, j - 1, 1) <> " " And Mid(veri, j, 1) <> " " Then
               Mid(veri, j, 1) = "*"
            End If
        Else
            If Mid(veri, j - 1, 1) <> " " And Mid(veri, j + 1, 1) <> " " And Mid(veri, j, 1) <> " " Then
               Mid(veri, j, 1) = "*"
            End If
        End If
    Next j
    If kriter = 0 Then Mid(veri, j, 1) = "*"
    YILDIZLA = veri
End Function

 

[Haluk]

Regular Expressions ile başka bir alternatif:

'   Haluk - 19/05/2020
'   sa4truss@gmail.com

Sub Test()
    MsgBox encryptString("Ali Rıza Binboğa", True)
    MsgBox encryptString("Ali Rıza Binboğa", False)
    
    MsgBox encryptString("Korkut Ekin", True)
    MsgBox encryptString("Korkut Ekin", False)
    
    MsgBox encryptString("Sarı Çizmeli Mehmet Ağa", True)
    MsgBox encryptString("Sarı Çizmeli Mehmet Ağa", False)
End Sub
'
Function encryptString(strText As String, LastChar As Boolean) As String
    Dim regExp As Object, objMatches As Object, tempStr As String, j As Byte, x As Byte
    
    Set regExp = CreateObject("VBScript.RegExp")
    
    regExp.IgnoreCase = True
    regExp.Global = True
    regExp.Pattern = "([A-Za-zIĞÜŞİÖÇıüşöç]+)"
    
    If regExp.Test(strText) Then
        Set objMatches = regExp.Execute(strText)
        For j = 0 To objMatches.Count - 1
            tempStr = objMatches.Item(j).Submatches(0)
            x = Len(tempStr)
            If LastChar = True Then
                myStr = myStr & " " & Left(tempStr, 1) & WorksheetFunction.Rept("*", x - 2) & Right(tempStr, 1)
            Else
                myStr = myStr & " " & Left(tempStr, 1) & WorksheetFunction.Rept("*", x - 1)
            End If
        Next
    End If
        
    encryptString = Trim(myStr)
    Set objMatches = Nothing
    Set regExp = Nothing
End Function

.

 

[aytacesmebasi]

Bu formül çalışıyor ama büyük İ harfinde karıştırıyor. Sorun nasıl düzelebilir acaba?

 

[aytacesmebasi]

Bu formül çalışıyor ama büyük İ harfinde karıştırıyor. Sorun nasıl düzelebilir acaba?

Excelde sorun yokmuş ama google etablolarda bu sorunu yaşıyorum. Sadece büyük İ harfi olursa formül sonucu karışıyor.

 

[Korhan Ayhan]

Hangi formül sıkıntı çıkarıyor?

 

[aytacesmebasi]

Asri beyin ilk yazdığı formül excelde sorunsuz çalışıyor ama google etabloda büyük İ harfi olan isimlerde sayma işlemini karıştırıyor bu da sonucu etkiliyor. Ben de çözüm için buraya geri dönmüştüm. Yerinekoy formülü ile büyük İ yerine küçük i ile değiştirme formülünü aşağıdaki formüle ekledim sorun çözüldü

=YERİNEKOY(C1;"İ";"i") şeklinde aşağıdaki bütün C1lere ekleme yaptım.

=SOLDAN(C1;1) & YİNELE("*";UZUNLUK(PARÇAAL(C1;1;MBUL(" ";C1;1)-1))-2) & PARÇAAL(C1;MBUL(" ";C1;1)-1;1) & " " & EĞER(EHATA(MBUL(" ";PARÇAAL(C1;MBUL(" ";C1;1)+1;UZUNLUK(C1))));SOLDAN(PARÇAAL(C1;MBUL(" ";C1;1)+1;UZUNLUK(C1));1) & YİNELE("*";UZUNLUK(PARÇAAL(C1;MBUL(" ";C1;1)+1;UZUNLUK(C1)))-2) & SAĞDAN(C1;1);SOLDAN(PARÇAAL(C1;MBUL(" ";C1;MBUL(" ";C1;1)+1)+1;UZUNLUK(C1));1) & YİNELE("*";UZUNLUK(PARÇAAL(C1;MBUL(" ";C1;MBUL(" ";C1;1)+1);UZUNLUK(C1)))-2) & SAĞDAN(C1;1))

 

[Korhan Ayhan]

Tebrikler...

 

[yyhy]

Günlük olarak tiryakisi olduğum excel.web.tr ailesinin çok değerli hocaları bu konuda yorumlarını yazmışlar.
Yine bir hocamızın videosunu izleyerek hazırladığım belki çözüm olmayabilir ama severek yaptığım bir çalışma dosyasını excel.web.tr ailesinin çok değerli hoca, moderatörleri ve üyeleri ile misafir kullanıcıları için ekliyorum.
Hatamız ve eksiğimiz varsa öncelikle özür dilerim.
İyi günler.

 

[Korhan Ayhan]

Elinize sağlık.. Paylaşımınız için teşekkürler.

 

[yyhy]

Hocam biz teşekkür ederiz.
Hocam sizlerden çok şeyler öğrendik.
Siz ve sizin gibi değerli hocalarımızın bilgilerini takip etmekten gurur duyuyoruz.
İyi çalışmalar hocam.

 

[Asri]

Günlük olarak tiryakisi olduğum excel.web.tr ailesinin çok değerli hocaları bu konuda yorumlarını yazmışlar.
Yine bir hocamızın videosunu izleyerek hazırladığım belki çözüm olmayabilir ama severek yaptığım bir çalışma dosyasını excel.web.tr ailesinin çok değerli hoca, moderatörleri ve üyeleri ile misafir kullanıcıları için ekliyorum.
Hatamız ve eksiğimiz varsa öncelikle özür dilerim.
İyi günler.

Elinize sağlık, Öneri olarak seçeneklere aşağıdakiler parametrik olarak eklenebilir.

- İlk 2 karakteri sabit diğerlerini maskele, karakter sayısı kadar. As** Ak*****
- İlk 2 karakteri sabit diğerlerini maskele, maske karakteri 3 adet . As*** Ak***