otomatik kod oluşturma

[mertcumhur]

Merhaba,

6 karakterden oluşan büyük harf ve rakamdan karışık şekilde oluşacak. ( örneğin : 6A21V5 ) . Özel işaretler olmayacak bir de ( İ-I-L-O-Ö harfleriyle 0 rakamı içermeyecek şekilde nasıl oluşturabilirim.

 

[Necdet]

Merhaba,
A sütununa harf ve rakamları yazınız.

İsteiğiniz hücreye :

=İNDİS($A$1:$A$29;RASTGELEARADA(1;29);1) &
İNDİS($A$1:$A$29;RASTGELEARADA(1;29);1) &
İNDİS($A$1:$A$29;RASTGELEARADA(1;29);1)&
İNDİS($A$1:$A$29;RASTGELEARADA(1;29);1)&
İNDİS($A$1:$A$29;RASTGELEARADA(1;29);1)&
İNDİS($A$1:$A$29;RASTGELEARADA(1;29);1)

formülünü uygulayınız. Formülü aşağıya doğru kopyaladıkça yeni kodlar oluşacaktır.

İlk aklıma gelen çözüm bu oldu.

 

[mertcumhur]

çok teşekkürler çok işime yaradı

 

[Muzaffer Ali]

Merhaba.
Alternatif olarak sadece A1'e karakterleri yazarak aşağıdaki formül ile çözüme ulaşabilirsiniz.
Formülü aşağıya doğru kopyalayarak çoğaltabilirsiniz.

=BİRLEŞTİR(
PARÇAAL($A$1;RASTGELEARADA(1;29);1);
PARÇAAL($A$1;RASTGELEARADA(1;29);1);
PARÇAAL($A$1;RASTGELEARADA(1;29);1);
PARÇAAL($A$1;RASTGELEARADA(1;29);1);
PARÇAAL($A$1;RASTGELEARADA(1;29);1);
PARÇAAL($A$1;RASTGELEARADA(1;29);1))

 

[mertcumhur]

Çok teşekkürler 8.000 adet bu şekilde kod oluşturacağım bunu tekrarsız yani mükerrer olmaması için ne yapmalıyım

 

[Muzaffer Ali]

Aşağıdaki kod Aktif sayfanın A kolonuna 8000 adet 6 karakterli, benzersiz kod üretir

Sub KodListele()
    Dim Karakterler As String
    Dim Kodlar As Object
    Dim Kod As Variant
    Dim Bak As Long
   
    Karakterler = "ABCDEFGHJKMNPQRSTUVWXYZ123456789"
    Set Kodlar = CreateObject("Scripting.Dictionary")
    Do While Kodlar.Count < 8000
        Kod = ""
        For Bak = 1 To 6
            Kod = Kod & Mid(Karakterler, Int(Rnd() * Len(Karakterler)) + 1, 1)
        Next
        If Not Kodlar.Exists(Kod) Then
            Kodlar.Add Kod, 1
        End If
    Loop
    Bak = 1
    For Each Kod In Kodlar.Keys
        Cells(Bak, "A").Value = Kod
        Bak = Bak + 1
    Next
    MsgBox "Tamamlandı."
End Sub

 

[Necdet]

Merhaba,
Alternatif olsun.
Aşağıdaki kodları ChatGPT yazdı.
Kodun daha rahat anlaşılması için de anlamlı parçalara bölmesi, kod yazma tekniği açısından çok önemli.
Aktif sayfanın A sütununa listeler.

Sub SifreUret()

    Dim sifreler As Collection
    Dim i As Long
    Dim adt As Long
   
    adt = Application.InputBox("Kaç Adet Şifre İstiyorsunuz?", "Kaç Adet", 8000, Type:=2)
    If adt < 1 Then
        MsgBox adt & " Adet Sayı İstiyorsunuz, ÇIKIYORUM...."
        Exit Sub
    End If
   
    Application.ScreenUpdating = False
   
    Set sifreler = BenzersizSifrelerUret(adt)
   
    Range("A:A").ClearContents
   
    For i = 1 To sifreler.Count
        Cells(i, 1) = sifreler(i)
    Next i
   
    Application.ScreenUpdating = True
   
End Sub

Function BenzersizSifrelerUret(ByVal adet As Long) As Collection
   
    Dim karakterler As String
    Dim sonuc As New Collection
    Dim sifre As String
   
    karakterler = "7SPZEY3H8RTJ6U1VLB9A2FCK54DG"
    Randomize
   
    Do While sonuc.Count < adet
        sifre = RastgeleSifre(karakterler, 6)
       
        ' Aynı şifre tekrar üretilmesin
        On Error Resume Next
        sonuc.Add sifre, sifre
        On Error GoTo 0
    Loop
   
    Set BenzersizSifrelerUret = sonuc
End Function

Function RastgeleSifre(ByVal karakterler As String, ByVal uzunluk As Long) As String
   
    Dim i As Long
    Dim index As Long
    Dim sifre As String
   
    For i = 1 To uzunluk
        index = Int(Rnd * Len(karakterler)) + 1
        sifre = sifre & Mid(karakterler, index, 1)
    Next i
   
    RastgeleSifre = sifre
End Function