Ardışık Olmayan ve Tekrar Etmeyen Sayı Üretme

[mertcumhur]

Merhaba,

Ardışık olmayan ve tekrar etmeyen 1 ile 999.999 aralığında rastgele 8.000 adet sayı nasıl üretebilirim. A1+2 veya 3... olmadan rastgele

 

[volki_112]

Merhaba,

Ardışık olmayan ve tekrar etmeyen 1 ile 999.999 aralığında rastgele 8.000 adet sayı nasıl üretebilirim. A1+2 veya 3... olmadan rastgele

istediğin işlemi yapacak vba kodu. açık sayfada A1 den itibaren listeler.

Sub GenerateRandomNumbers()
    Dim numList() As Long
    Dim i As Long
    Dim n As Long
    Dim temp As Long
    Dim randIndex As Long
    Dim numCount As Long
    Dim ws As Worksheet

    ' Sayıların sınırı
    n = 999999
    numCount = 8000

    ' Aktif çalışma sayfasını belirle
    Set ws = ActiveSheet
    
    ' 1 ile 999999 arasında ardışık sayıları listele
    ReDim numList(1 To n)
    For i = 1 To n
        numList(i) = i
    Next i

    ' Sayıları karıştırmak (Fisher-Yates algoritması)
    For i = n To 2 Step -1
        randIndex = Int((i - 1 + 1) * Rnd + 1) ' Rastgele indeks
        temp = numList(i)
        numList(i) = numList(randIndex)
        numList(randIndex) = temp
    Next i

    ' İlk 8000 sayıyı aktif sayfaya A1'den başlayarak yaz
    For i = 1 To numCount
        ws.Cells(i, 1).Value = numList(i)
    Next i

    MsgBox numCount & " random numbers generated successfully on the active sheet."
End Sub

 

[mertcumhur]

çok teşekkürler emeğinize sağlık

 

[polis-53]

bir de küçükten büyüğe doğru sıralama yapsın

 

[volki_112]

bir de küçükten büyüğe doğru sıralama yapsın

Küçükten büyüğe siralama dahil edilmis kod

Sub GenerateRandomNumbers()

    Dim numList() As Long

    Dim i As Long

    Dim n As Long

    Dim temp As Long

    Dim randIndex As Long

    Dim numCount As Long

    Dim ws As Worksheet

    ' Sayıların sınırı

    n = 999999

    numCount = 8000

    ' Aktif çalışma sayfasını belirle

    Set ws = ActiveSheet

    

    ' 1 ile 999999 arasında ardışık sayıları listele

    ReDim numList(1 To n)

    For i = 1 To n

        numList(i) = i

    Next i

    ' Sayıları karıştırmak (Fisher-Yates algoritması)

    For i = n To 2 Step -1

        randIndex = Int((i - 1 + 1) * Rnd + 1) ' Rastgele indeks

        temp = numList(i)

        numList(i) = numList(randIndex)

        numList(randIndex) = temp

    Next i

    ' İlk 8000 sayıyı aktif sayfaya A1'den başlayarak yaz

    For i = 1 To numCount

        ws.Cells(i, 1).Value = numList(i)

    Next i

    ' Sıralama işlemi

    With ws.Sort

        .SortFields.Clear

        .SortFields.Add Key:=ws.Range("A1:A" & numCount), Order:=xlAscending

        .SetRange ws.Range("A1:A" & numCount)

        .Header = xlNo

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

    MsgBox numCount & " random numbers generated and sorted successfully on the active sheet."

End Sub

 

[volki_112]

@polis-53 küçükten büyüğe sıralama için daha hızlı kod

Sub GenerateRandomNumbers()
    Dim i As Long
    Dim numCount As Long
    Dim ws As Worksheet
    Dim dataArray() As Long
    Dim usedNumbers As Object
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    numCount = 8000
    Set ws = ActiveSheet
    
    ' Dictionary oluştur
    Set usedNumbers = CreateObject("Scripting.Dictionary")
    
    ' Tek seferde yazılacak dizi için boyut belirleme
    ReDim dataArray(1 To numCount, 1 To 1)
    
    ' Rastgele benzersiz sayıları üret
    Randomize
    i = 1
    Do While i <= numCount
        Dim randNum As Long
        randNum = Int((999999) * Rnd + 1)
        
        ' Eğer sayı daha önce kullanılmadıysa
        If Not usedNumbers.Exists(randNum) Then
            usedNumbers.Add randNum, 1
            dataArray(i, 1) = randNum
            i = i + 1
        End If
    Loop
    
    ' Tüm veriyi tek seferde yaz
    ws.Range("A1:A" & numCount).Value = dataArray
    
    ' Sıralama işlemi
    ws.Range("A1:A" & numCount).Sort Key1:=ws.Range("A1"), Order1:=xlAscending
    
    ' Temizlik
    Set usedNumbers = Nothing
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox numCount & " random numbers generated and sorted successfully."
End Sub

 

[ÖmerBey]

Merhaba,
Acizane küçük bir ilave:
Ardışık olmayan şartının sağlanması için sayın volki_112'nin paylaştığı son koda aşağıdaki kırmızı kısım eklenebilir.

        If Not usedNumbers.Exists(randNum) And Not usedNumbers.Exists(randNum + 1) Then
            usedNumbers.Add randNum, 1
            usedNumbers.Add randNum + 1, 1
            dataArray(i, 1) = randNum
            i = i + 1
        End If

İyi çalışmalar...