Soru Harflerin arasına * koyma

[katip06]

Arkadaşlar merhaba, yapmak istediğim örnek dosyada da belirttiğim gibi, isim soyisim kısımlarını şifreli hale getirmek, yani bütün bilgiyi göstermek yerine her harften sonra * koyarak şifreli hale getirmek. Her hücrenin uzunluğu farklı olduğundan net bir formül yazamadım, yardımcı olabilecek arkadaşlara şimdiden teşekkür ederim.

 

[Korhan Ayhan]

Burada benzer bir konu işlemiştik.

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

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?

www.excel.web.tr

 

[Korhan Ayhan]

Verdiğim linkteki kullanıcı tanımlı fonksiyonu sizin talebinize göre revize ettim.

Aşağıdaki gibi kullanabilirsiniz.

Dosyanızda C2 hücresine =KODLA(A2&" "&B2;"*";2) şeklinde uyguladığınızda istediğiniz sonuca ulaşabilirsiniz. Fonksiyonun sonundaki 2 parametresini 0 ve 1 olarak değiştirerek farklı görünümler elde edebilirsiniz.

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, Y 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, " ")
    ElseIf Kriter = 2 Then
        ReDim Dizi(1 To 1)
        Kelime = Split(WorksheetFunction.Trim(Veri), " ")
        For X = 0 To UBound(Kelime)
            Metin = ""
            Say = Say + 1
            ReDim Preserve Dizi(1 To Say)
            For Y = 1 To Len(Kelime(X))
                If Y Mod 2 = 0 Then
                    Metin = IIf(Metin = "", Karakter, Metin & Karakter)
                Else
                    Metin = IIf(Metin = "", Mid(Kelime(X), Y, 1), Metin & Mid(Kelime(X), Y, 1))
                End If
            Next
            Dizi(Say) = Metin
        Next
        KODLA = Join(Dizi, " ")
    Else
        KODLA = "Uygun parametre giriniz!"
    End If
End Function

 

[katip06]

Verdiğim linkteki kullanıcı tanımlı fonksiyonu sizin talebinize göre revize ettim.

Aşağıdaki gibi kullanabilirsiniz.

Dosyanızda C2 hücresine =KODLA(A2&" "&B2;"*";2) şeklinde uyguladığınızda istediğiniz sonuca ulaşabilirsiniz. Fonksiyonun sonundaki 2 parametresini 0 ve 1 olarak değiştirerek farklı görünümler elde edebilirsiniz.

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, Y 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, " ")
    ElseIf Kriter = 2 Then
        ReDim Dizi(1 To 1)
        Kelime = Split(WorksheetFunction.Trim(Veri), " ")
        For X = 0 To UBound(Kelime)
            Metin = ""
            Say = Say + 1
            ReDim Preserve Dizi(1 To Say)
            For Y = 1 To Len(Kelime(X))
                If Y Mod 2 = 0 Then
                    Metin = IIf(Metin = "", Karakter, Metin & Karakter)
                Else
                    Metin = IIf(Metin = "", Mid(Kelime(X), Y, 1), Metin & Mid(Kelime(X), Y, 1))
                End If
            Next
            Dizi(Say) = Metin
        Next
        KODLA = Join(Dizi, " ")
    Else
        KODLA = "Uygun parametre giriniz!"
    End If
End Function

Çok teşekkür ederim Korhan Hocam, elinize emeğinize sağlık.