Random Şifre Oluşturma

[Erdogan3434]

Merhabalar,

Ekte örneğini belirttiğim dosya da B hücresine yazdığım personel adının yanına personelin isminin ve soyisminin ilk harflerini (türkçe karakter içermeyecek şekilde) direkt büyük harf olabilir ve sonrasında random 4 hane rakamda içerek şekilde toplamda 6 hane şifre oluşturmasını oluşturulan şifrenin benzersiz olmasını(burası çok önemli) rica ediyorum.

Teşekkürler,

 

[ÖmerFaruk]

Aşağıdaki kodları boş bir modül içine ekleyip sayfanızda çalıştırabilirsiniz.

Sub PasswordList()
    Dim isim, Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    For i = 2 To Range("A" & Rows.Count).End(3).Row
        If Range("B" & i) <> "" Then
            isim = Split(Range("B" & i), " ")
            PassPart1 = Left(isim(LBound(isim)), 1) & Left(isim(UBound(isim)), 1)
            Do
                PassPart2 = WorksheetFunction.RandBetween(1111, 9999)
            Loop Until Not Dict.Exists(PassPart1 & PassPart2)
            Dict.Add Pass1 & PassPart2, 1
            Range("C" & i) = PassPart1 & PassPart2
        End If
    Next i
End Sub

 

[Erdogan3434]

Sadece satır numarası yazan isim soyisim bilgisi yazmayan bir satıra denk geldiğinde sorgu hata döndürüyor. Eğer isim soyisim yoksa o satırı boş bırakacak şekilde düzenleme yapabilir misiniz?

 

[Erdogan3434]

Sadece satır numarası yazan isim soyisim bilgisi yazmayan bir satıra denk geldiğinde sorgu hata döndürüyor. Eğer isim soyisim yoksa o satırı boş bırakacak şekilde düzenleme yapabilir misiniz?

 

[ÖmerFaruk]

Önceki mesajdaki kodlara IF sorgusu ilave ettim. Tekrar deneyebilirsiniz.

 

[Erdogan3434]

Önceki mesajdaki kodlara IF sorgusu ilave ettim. Tekrar deneyebilirsiniz.

Çok teşekkür ederim.

 

[Erdogan3434]

Önceki mesajdaki kodlara IF sorgusu ilave ettim. Tekrar deneyebilirsiniz.

Ömer Faruk bey öncelikle desteğiniz için çok teşekkür ederim. Eğer mümkün olursa daha önce oluşturulmuş bir şifre varsa olduğu gibi bırakmasını sadece yeni bir şifre oluşturulacaksa oluşturmasını da ekleyebilir misiniz ?
Şimdiden çok teşekkür ederim.

 

[ÖmerFaruk]

Daha önce oluşturulmuşlar da aynı formattamıdır?
Bazıları aynı bazıları farklı formattaysa farklı olanları aynı format olacak şekilde değişecek miyiz?

Daha önce oluşturulmuşlar içinde mükerrer şifre olması durumunda nasıl önlem alacağız?
Mükerrer kontrolü yapabiliriz. Mükerrer varsa ilkinden sonrakileri siler yeni şifre oluştururuz. Ya da mükerrer olma ihtiamli asla yoktur derseniz ve aslında gözden kaçmış bir mükerrer varsa kodlar ne yapacak?

 

[Erdogan3434]

Daha önce oluşturulmuşlar da aynı formattamıdır?
Bazıları aynı bazıları farklı formattaysa farklı olanları aynı format olacak şekilde değişecek miyiz?

Daha önce oluşturulmuşlar içinde mükerrer şifre olması durumunda nasıl önlem alacağız?
Mükerrer kontrolü yapabiliriz. Mükerrer varsa ilkinden sonrakileri siler yeni şifre oluştururuz. Ya da mükerrer olma ihtiamli asla yoktur derseniz ve aslında gözden kaçmış bir mükerrer varsa kodlar ne yapacak?

Ömer Faruk bey daha önce oluşturulanlar da aynı formattadır. Mükerrer kontrolü yaparak ilkinden sonrakileri silip yeniden oluşturmak benim işim için muhteşem olacaktır. Tek liste üzerinde çalışacağım ve bu liste tamamen sizin kodunuzla çalışacağı ve önceki kayıtlarda hiç mükerrer olmadığı için oluşturmadan önce mükerrer kontrolü yaparsa benim tüm işimi çözmüş olacaktır.

Saygılarımla,

 

[ÖmerFaruk]

Aşağıdaki kodu kullanın.
Mevcut ve benzersiz yani değiştirilmeyecek şifreler Yeşil olarak işaretlenecek.
Mevcut ama benzeri olan varsa yeni şifre konulup sarıya boyanacak
Mevcut olmayanlar renklendirmeden oluşturulacak.

Mevcutlarda İlkharfler ve 4 basamaklı sayıdan oluşacak şekilde bir format kontrolü yapmadım.

Sub PasswordList()
    Dim isim, PassDict As Object
    Set PassDict = CreateObject("Scripting.Dictionary")
    Range("C2:C" & Range("A" & Rows.Count).End(3).Row).Interior.Color = xlNone
    For i = 2 To Range("A" & Rows.Count).End(3).Row
        If Range("B" & i) = "" Then
            Range("C" & i) = ""
        ElseIf Range("C" & i) <> "" Then
        x = PassDict.Count
            If PassDict.Exists(Range("C" & i).Text) Then
                Range("C" & i) = "Yenisifre"
            Else
                PassDict.Add Range("C" & i).Text, 1
                Range("C" & i).Interior.Color = vbGreen
            End If
        End If
        
    Next i
    For i = 2 To Range("A" & Rows.Count).End(3).Row
        If Range("B" & i) <> "" Then
            If Range("C" & i) = "" Or Range("C" & i) = "Yenisifre" Then
                isim = Split(Range("B" & i), " ")
                PassPart1 = Left(isim(LBound(isim)), 1) & Left(isim(UBound(isim)), 1)
                Do
                    PassPart2 = WorksheetFunction.RandBetween(1111, 9999)
                Loop Until Not PassDict.Exists(PassPart1 & PassPart2)
                PassDict.Add Pass1 & PassPart2, 1
                If Range("C" & i) <> "" Then Range("C" & i).Interior.Color = vbYellow
                Range("C" & i) = PassPart1 & PassPart2
            End If
        End If
    Next i
End Sub

 

[Erdogan3434]

Aşağıdaki kodu kullanın.
Mevcut ve benzersiz yani değiştirilmeyecek şifreler Yeşil olarak işaretlenecek.
Mevcut ama benzeri olan varsa yeni şifre konulup sarıya boyanacak
Mevcut olmayanlar renklendirmeden oluşturulacak.

Mevcutlarda İlkharfler ve 4 basamaklı sayıdan oluşacak şekilde bir format kontrolü yapmadım.

Sub PasswordList()
    Dim isim, PassDict As Object
    Set PassDict = CreateObject("Scripting.Dictionary")
    Range("C2:C" & Range("A" & Rows.Count).End(3).Row).Interior.Color = xlNone
    For i = 2 To Range("A" & Rows.Count).End(3).Row
        If Range("B" & i) = "" Then
            Range("C" & i) = ""
        ElseIf Range("C" & i) <> "" Then
        x = PassDict.Count
            If PassDict.Exists(Range("C" & i).Text) Then
                Range("C" & i) = "Yenisifre"
            Else
                PassDict.Add Range("C" & i).Text, 1
                Range("C" & i).Interior.Color = vbGreen
            End If
        End If
       
    Next i
    For i = 2 To Range("A" & Rows.Count).End(3).Row
        If Range("B" & i) <> "" Then
            If Range("C" & i) = "" Or Range("C" & i) = "Yenisifre" Then
                isim = Split(Range("B" & i), " ")
                PassPart1 = Left(isim(LBound(isim)), 1) & Left(isim(UBound(isim)), 1)
                Do
                    PassPart2 = WorksheetFunction.RandBetween(1111, 9999)
                Loop Until Not PassDict.Exists(PassPart1 & PassPart2)
                PassDict.Add Pass1 & PassPart2, 1
                If Range("C" & i) <> "" Then Range("C" & i).Interior.Color = vbYellow
                Range("C" & i) = PassPart1 & PassPart2
            End If
        End If
    Next i
End Sub

Emeğiniz ve desteğiniz için çok teşekkür ederim.

 

[ÖmerFaruk]

Eyvallah. Kolay gelsin.

 

[Erdogan3434]

Eyvallah. Kolay gelsin.

Merhaba Ömer Faruk Bey,

Daha önce random şifre oluşturma noktasında çok yardımınız dokunmuştu. Bu kod yapısı çok işime yaradığı için farklı bir operasyonda daha kullanmak istiyorum. Burada yapmak istediğim 3 aşamalı totalde 7 haneden oluşan şifreler oluşturmak. Bunların ilk iki harf isim soyisimin ilk harfleri, sonraki 4 rakam random ve sonlarında * işareti olacak şekildedir. Tam taslağı hazır olan şifrenin harf kısmında ilk harfinin standart büyük ikinci harfinin standart küçük olması noktasında aşağıdaki kodu düzenleyebilir misiniz?


Private Sub CommandButton1_Click()
Dim isim, PassDict As Object
Set PassDict = CreateObject("Scripting.Dictionary")
Range("D2" & Range("B" & Rows.Count).End(3).Row).Interior.Color = xlNone
For i = 2 To Range("B" & Rows.Count).End(3).Row
If Range("A" & i) = "" Then
Range("D" & i) = ""
ElseIf Range("D" & i) <> "" Then
x = PassDict.Count
If PassDict.Exists(Range("D" & i).Text) Then
Range("D" & i) = "Yenisifre"
Else
PassDict.Add Range("D" & i).Text, 1
Range("D" & i).Interior.Color = vbGreen
End If
End If

Next i
For i = 2 To Range("B" & Rows.Count).End(3).Row
If Range("A" & i) <> "" Then
If Range("D" & i) = "" Or Range("D" & i) = "Yenisifre" Then
isim = Split(Range("A" & i), " ")
PassPart1 = Left(isim(LBound(isim)), 1) & Left(isim(UBound(isim)), 1)
Do
PassPart2 = WorksheetFunction.RandBetween(1111, 9999)
PassPart3 = "*"
Loop Until Not PassDict.Exists(PassPart1 & PassPart2 & PassPart3)
PassDict.Add Pass1 & PassPart2 & PassPart3, 1
If Range("D" & i) <> "" Then Range("D" & i).Interior.Color = vbYellow
Range("D" & i) = PassPart1 & PassPart2 & PassPart3
End If
End If
Next i



Teşekkürler.
MsgBox ("Şifreler Oluşturuldu")
End Sub

 

[bycakir]

ömer beyin kodları kullanabilirsiniz sadece sbir satırda düzeltme yapacaksınız

Range("C" & i) = PassPart1 & PassPart2 & "*"

bukadar

 

[Erdogan3434]

ömer beyin kodları kullanabilirsiniz sadece sbir satırda düzeltme yapacaksınız

Range("C" & i) = PassPart1 & PassPart2 & "*"

bukadar

Merhabalar,

Yukarıda düzenlediğim de sorunsuz çalışıyor ancak ben Passpart1 kısmında olan harf bölümünün ilkinin büyük ikincisinin küçük olmasını sağlamaya çalışıyorum açıkçası. Yani yapmak istediğim örnek tasarım formatı De1596* şeklindedir.

İyi çalışmalar,

 

[ÖmerFaruk]

Aşağıdaki satırda gösterdiğim ilaveyi yaparrak denermisiniz.
PassPart1 = Left(isim(LBound(isim)), 1) & Lcase(Left(isim(UBound(isim)), 1))

 

[Erdogan3434]

Aşağıdaki satırda gösterdiğim ilaveyi yaparrak denermisiniz.
PassPart1 = Left(isim(LBound(isim)), 1) & Lcase(Left(isim(UBound(isim)), 1))

Tam istediğim gibi çok teşekkür ederim.