Kelimenin ilk 2 karekterinden sonra maskeleme

[vuranoğlu]

İyi akşamlar
Kelimenin ilk 2 karekterinden sonra maskeleme "****" gibi makro ile nasıl yapılabilir.?
İlgilenen arkadaşlara şimdiden teşekkürler

 

[Ömer]

Merhaba,

Deneyiniz.

Sub deneme()

    Dim d, i As Byte, a As String
    
    d = Split([A1], " ")
    
    For i = 0 To UBound(d)
        a = WorksheetFunction.Replace(d(i), 3, 256, String(Len(d(i)) - 2, "*"))
        [A3] = [A3] & " " & a
    Next i
    
End Sub

 

[vuranoğlu]

Teşekkürler.
Bu uygulamayı adres verilerinin girişinde kullanmak istiyorum.Yani yazım anında yada hücreden çıkınca bu hale gelsin.

 

[Ömer]

Tam anlayamadım. Hücredeki veriyi bu hale getirince eski veriye nasıl ulaşacaksınız. Bu veriler başka bir sayfada kayıt mı olacak.

 

[vuranoğlu]

Maskeleme hücreye veri girildiğinde maskelenecek. Tablo sevk edileceği için bazı verilerin maskelenmesi gerekiyor.
Yapmış olduğum çalışma ektedir.

 

[Korhan Ayhan]

Sayfanızın kod bölümündeki kodları silip aşağıdaki kodu uygulayıp deneyiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Veri As Range, Metin As Variant, X As Integer, Sonuc As String
    
    On Error GoTo Son
    
    Application.EnableEvents = False
    
    If Not Intersect(Target, Range("H12:M26")) Is Nothing Then
        Range("B12:C26").ClearContents
        If WorksheetFunction.CountA(Range("H12:M26")) > 0 Then
            With Range("B12:B" & Application.Evaluate("LOOKUP(2,1/(H12:M26<>""""),ROW(H12:M26))"))
                .Formula = "=ROW(A1)"
                .Value = .Value
            End With
        End If
    ElseIf Not Intersect(Target, Range("AA12:AK26")) Is Nothing Then
        For Each Veri In Intersect(Target, Range("AA12:AK26")).Columns(1).Cells
            If InStr(1, Veri.Value, " ") = 0 Then
                Veri.Value = Left(Veri.Value, 2) & WorksheetFunction.Rept("*", Len(Veri.Value) - 2)
            Else
                Metin = Split(Veri.Value, " ")
                For X = LBound(Metin) To UBound(Metin)
                    If Len(Metin(X)) >= 3 Then
                        If Sonuc = Empty Then
                            Sonuc = Left(Metin(X), 2) & WorksheetFunction.Rept("*", Len(Metin(X)) - 2)
                        Else
                            Sonuc = Sonuc & " " & Left(Metin(X), 2) & WorksheetFunction.Rept("*", Len(Metin(X)) - 2)
                        End If
                    Else
                        Sonuc = IIf(Sonuc = Empty, Metin(X), Sonuc & " " & Metin(X))
                    End If
                Next
                If Sonuc <> "" Then Target = Sonuc: Sonuc = ""
            End If
        Next
    End If

Son: Application.EnableEvents = True
End Sub

 

[mc_exrem]

Merak ettim çalıştı mı acaba?

 

[vuranoğlu]

İyi akşamlar.
Sayın Korhan AYHAN
İlginize teşekkür ederim.
Otomatik sıra no vermesi güzel olmuş ancak boş olan hücrelere de sıra no veriyor.
Örnek ektedir.

 

[Korhan Ayhan]

Nasıl kullanacağınızı belirtmediğiniz için o şekilde kurgulamıştım.

Sadece dolu hücrelere sıra no vermek için aşağıdaki kodu deneyebilirsiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Veri As Range, Metin As Variant, X As Integer, Sonuc As String
    
    On Error GoTo Son
    
    Application.EnableEvents = False
    
    If Not Intersect(Target, Range("H12:M26")) Is Nothing Then
        Range("B12:C26").ClearContents
        If WorksheetFunction.CountA(Range("H12:M26")) > 0 Then
            With Range("B12:B" & Application.Evaluate("LOOKUP(2,1/(H12:M26<>""""),ROW(H12:M26))"))
                .Formula = "=IF(H12="""","""",SUBTOTAL(3,H$12:H12))"
                .Value = .Value
            End With
        End If
    ElseIf Not Intersect(Target, Range("AA12:AK26")) Is Nothing Then
        For Each Veri In Intersect(Target, Range("AA12:AK26")).Columns(1).Cells
            If InStr(1, Veri.Value, " ") = 0 Then
                Veri.Value = Left(Veri.Value, 2) & WorksheetFunction.Rept("*", Len(Veri.Value) - 2)
            Else
                Metin = Split(Veri.Value, " ")
                For X = LBound(Metin) To UBound(Metin)
                    If Len(Metin(X)) >= 3 Then
                        If Sonuc = Empty Then
                            Sonuc = Left(Metin(X), 2) & WorksheetFunction.Rept("*", Len(Metin(X)) - 2)
                        Else
                            Sonuc = Sonuc & " " & Left(Metin(X), 2) & WorksheetFunction.Rept("*", Len(Metin(X)) - 2)
                        End If
                    Else
                        Sonuc = IIf(Sonuc = Empty, Metin(X), Sonuc & " " & Metin(X))
                    End If
                Next
                If Sonuc <> "" Then Target = Sonuc: Sonuc = ""
            End If
        Next
    End If

Son: Application.EnableEvents = True
End Sub

 

[Asri]

Bir programım için çalışma yapmıştım.
Alternatif değildir. Doyanız ile uyumlu değil.
Ancak farklı bir çalışma olarak incelenebilir.

* Adı Soyadı bilgisinde * yıldız ekleme özelliği
* Metinlerde boşluk karakterine kadar kelime olarak işlem yapar.
* Görünen karakter sayısı belirlenebilir
* Yıldız karakteri için karakter belirlenebilir
* Sabit yıldız seçimi yapılabilir. Sabit yıldız sayısı belirlenebilir

Sub isimyildizekle()
'Asri Akdeniz - www.asriakdeniz.com - asriakdeniz@gmail.com
    Dim veri, harf, yeniveri As String

    For Each hucre In Selection
        If hucre <> Empty Then
           veri = hucre
           veri = Trim(veri)
        
           basla = 0
           yeniveri = ""
           harf = ""
           baslahucre = 0
           For i = 1 To Len(veri)
              harf = Mid(veri, i, 1)
              baslahucre = baslahucre + 1
              If (harf <> "" And harf <> " ") And baslahucre > Val(gorunensay.Value) Then
                 If yildizsabit.Value And baslahucre > Val(gorunensay.Value) + 1 Then
                    harf = "~"
                 Else
                    harf = yildizkarakteri.Value
                 End If
              End If
              If harf = " " Then
                 baslahucre = 0
              End If
              yeniveri = yeniveri & harf
           Next i
        End If
      
        If yildizsabit.Value Then
           yeniveri = Replace(yeniveri, "~", "")
           harf = ""
           For i = 1 To Val(yildizsayisi.Value)
            harf = harf & yildizkarakteri.Value
           Next i
           hucre = Replace(yeniveri, yildizkarakteri.Value, harf)
        Else
           hucre = yeniveri
        End If
          
    Next
End Sub