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

merrrakli · 19 Mayıs 2020

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 · 19 Mayıs 2020

Formül işlerinden pek anlamam.

D1 e yapıştırıp aşağı çekin.

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

Kod:

=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.

Kod:

'=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 · 19 Mayıs 2020

@Asri Bey makro ile nasıl yapabiliriz.

muratboz06 · 19 Mayıs 2020

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.

Kod:

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 · 19 Mayıs 2020

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

Asri' Alıntı:

Formül işlerinden pek anlamam.

D1 e yapıştırıp aşağı çekin.

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

Kod:

=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.

Kod:

'=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 · 19 Mayıs 2020

Merhaba,

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

Kod:

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 · 19 Mayıs 2020

merrrakli' Alıntı:
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 · 19 Mayıs 2020

Utekiner' Alıntı:
@Asri Bey makro ile nasıl yapabiliriz.

Alternatif;

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

Kod:

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 · 19 Mayıs 2020

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)

C++:

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 · 19 Mayıs 2020

@Korhan Ayhan ın yöntemini sevdim. Fonksiyona eklendi.

Aynı koşul geçerlidir.

Kod:

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 · 19 Mayıs 2020

Regular Expressions ile başka bir alternatif:

Kod:

'   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 · 11 Haziran 2020

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

aytacesmebasi · 11 Haziran 2020

aytacesmebasi' Alıntı:
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 · 11 Haziran 2020

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

aytacesmebasi · 11 Haziran 2020

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.

Kod:

=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 · 11 Haziran 2020

Tebrikler...

yyhy · 8 Şubat 2022

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 · 8 Şubat 2022

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

yyhy · 8 Şubat 2022

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 · 9 Şubat 2022

yyhy' Alıntı:
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***

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

merrrakli

Ekli dosyalar

Asri

Utekiner

muratboz06

Destek Ekibi

merrrakli

Necdet

Moderatör

Asri

Asri

Korhan Ayhan

Administrator

Ekli dosyalar

Asri

Haluk

Özel Üye

aytacesmebasi

aytacesmebasi

Korhan Ayhan

Administrator

aytacesmebasi

Korhan Ayhan

Administrator

yyhy

Ekli dosyalar

Korhan Ayhan

Administrator

yyhy

Asri