benzersiz 4 haneli sayı ve harf üretme

[chakistes]

merhaba arkadaşlar excelde a1 den başlayarak biteceği satıra kadar kadar sadece ABCDEF haflerden ve 0123456789 içeren 4 haneli sayı ve haf karışımı yapablirmiyiz.
ÖRNEK
AAAA
A1AA
A2BA
AF9F
gibi ama benzersiz olacak

 

[veyselemre]

Sub test()
    
    Dim kactane&, k, i&, hepsi$
    kactane = 1000
    Range("A1:A" & Rows.Count).ClearContents
    Range("A1:A" & kactane).NumberFormat = "@"
    k = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, "A", "B", "C", "D", "E", "F")

    With CreateObject("Scripting.Dictionary")
        For i = 1 To kactane
basla:
            hepsi = k(WorksheetFunction.RandBetween(0, 15))
            hepsi = hepsi & k(WorksheetFunction.RandBetween(0, 15))
            hepsi = hepsi & k(WorksheetFunction.RandBetween(0, 15))
            hepsi = hepsi & k(WorksheetFunction.RandBetween(0, 15))
            If Not .exists(hepsi) Then
                .Item(hepsi) = Null
                Cells(i, 1).Value = hepsi
            Else
                GoTo basla
            End If
        Next i
    End With

End Sub

 

[chakistes]

teşekkür ederim eline sağlık

 

[veyselemre]

Tek seferde yazdırıldı. Application.Transpose kullanıldığı için en fazla 32555 adet üretebilir.

Sub test()

    Dim kactane%, k, i As Byte, hepsi$
    kactane = 100
    Range("A1:A" & Rows.Count).ClearContents
    Range("A1:A" & kactane).NumberFormat = "@"
    k = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, "A", "B", "C", "D", "E", "F")

    With CreateObject("Scripting.Dictionary")
        Do
            hepsi = ""
            For i = 1 To 4
                hepsi = hepsi & k(WorksheetFunction.RandBetween(0, 15))
            Next i
            .Item(hepsi) = Null
        Loop Until .Count = kactane
        Range("A1").Resize(kactane).Value = Application.Transpose(.keys)
    End With

End Sub