8 Haneli benzersiz bir kod üretmek

[ywzyilmaz]

Merhaba İyi akşamlar

Makroyu her çalıştırdığımda sayfa 2de A sütunundaki en son satıra benzersiz bir kod kaydetmesini istiyorum. Makroyu her çalıştırdığımda aynı işlemi tekrarlayacak. Bunu yapmam mümkün mü acaba? Yardımcı olabilecek varsa sevinirim.

 

[ÖmerFaruk]

Neye benzemeyeceğini tarif edebilirseniz dediğiniz mümkündür.

 

[ywzyilmaz]

sadece rakamlardan oluşan 8 haneli bir kod. A sütunu komple bu veri için ayrılacak, a hücresindeki hiç bir veri birbirinin aynısı olmasın yeter.

 

[ÖmerFaruk]

Aşağıdaki kodu boş bir module ekleyip sayfa üzerinde çalıştırabilirsiniz.
A2 den itibaren 8 haneli 11111111 - 99999999 arasında değere sahip şifre oluşturur

Sub PasswordList()
    Dim Dict As Object, Son As Long, i As Long, mPass As String
    Set Dict = CreateObject("Scripting.Dictionary")
    'A2 den itibaren aşağıya doğru şifre oluşturur
    Son = WorksheetFunction.Max(2, Range("A" & Rows.Count).End(3).Row)
    If Range("A2") <> "" Then
        For i = 2 To Son
            If Not Dict.Exists(Range("A" & i)) Then
                Dict.Add Range("A" & i), 1
            End If
        Next i
        Do
            myPass = WorksheetFunction.RandBetween(11111111, 99999999)
        Loop Until Not Dict.Exists(myPass)
        Range("A" & Son + 1) = myPass
    Else
        Range("A" & Son) = WorksheetFunction.RandBetween(11111111, 99999999)
    End If
End Sub

 

[ywzyilmaz]

Aşağıdaki kodu boş bir module ekleyip sayfa üzerinde çalıştırabilirsiniz.
A2 den itibaren 8 haneli 11111111 - 99999999 arasında değere sahip şifre oluşturur

Sub PasswordList()
    Dim Dict As Object, Son As Long, i As Long, mPass As String
    Set Dict = CreateObject("Scripting.Dictionary")
    'A2 den itibaren aşağıya doğru şifre oluşturur
    Son = WorksheetFunction.Max(2, Range("A" & Rows.Count).End(3).Row)
    If Range("A2") <> "" Then
        For i = 2 To Son
            If Not Dict.Exists(Range("A" & i)) Then
                Dict.Add Range("A" & i), 1
            End If
        Next i
        Do
            myPass = WorksheetFunction.RandBetween(11111111, 99999999)
        Loop Until Not Dict.Exists(myPass)
        Range("A" & Son + 1) = myPass
    Else
        Range("A" & Son) = WorksheetFunction.RandBetween(11111111, 99999999)
    End If
End Sub

çok teşekkürler üstadım. elinize sağlık.

 

[muratgunay48]

Aşağıdaki kodu boş bir module ekleyip sayfa üzerinde çalıştırabilirsiniz.
A2 den itibaren 8 haneli 11111111 - 99999999 arasında değere sahip şifre oluşturur

Sub PasswordList()
    Dim Dict As Object, Son As Long, i As Long, mPass As String
    Set Dict = CreateObject("Scripting.Dictionary")
    'A2 den itibaren aşağıya doğru şifre oluşturur
    Son = WorksheetFunction.Max(2, Range("A" & Rows.Count).End(3).Row)
    If Range("A2") <> "" Then
        For i = 2 To Son
            If Not Dict.Exists(Range("A" & i)) Then
                Dict.Add Range("A" & i), 1
            End If
        Next i
        Do
            myPass = WorksheetFunction.RandBetween(11111111, 99999999)
        Loop Until Not Dict.Exists(myPass)
        Range("A" & Son + 1) = myPass
    Else
        Range("A" & Son) = WorksheetFunction.RandBetween(11111111, 99999999)
    End If
End Sub

Emeğinize sağlık hocam. 6 haneli bana da lazımdı.