Tekrarsız, ard arda gelenlerin farkı 30 dan büyük olan rastgele sayı listesi

[Tevfik_Kursun]

Günaydın Arkadaşlar,
A3:A462 arasında 1 den 460 a kadar sayılar sıralı olarak verilmiştir. C3:C462 arasında bu sayıların tekrarsız, ard arda gelenlerin farkı 30 dan büyük olan rastgele sayı listesini oluşturmak istiyorum.

D3:D462

arasında tekrarlanmalar, E3:E462 arasında ise ard arda gelen sayılar arasındaki farklar koltrol ediliyor. D1 ve E1 de de kontrol sonuçları gözlemleniyor.

Sub deneme()
    Range("C3:C462").Clear
        With Range("C3:C462")
         .Formula = "= Randbetween(1,460)"
         .Value = .Value
        End With
End Sub

C sütununa random olarak liste yapan makro bu. Nasıl eklemeler yapmalıyım ki D1 ve E1 hücreleri sıfır olsun.
Saygılarımla

 

[YUSUF44]

Aşağıdaki kod tekrarsız isteğinizi karşılıyor ama 30'dan fazla fark olmaması biraz zor. Çünkü 459'un değer 250 ise ve geriye sadece 281 ve daha büyük sayı ya da 219 ve daha küçük bir sayı ise yani son kalan sayı sondan bir önceki sayıdan 30 farklıysa makro sonsuz döngüye girip exceli kilitliyor. Bu nedenle makroda onun için yaptığım düzenlemeyi iptal ettim.

Sub deneme()
    Range("C3:C462").Clear
    Application.ScreenUpdating = False
        For i = 3 To 462
10:
            say = WorksheetFunction.RandBetween(1, 460)
            If WorksheetFunction.CountIf(Range("C2:C" & i), say) > 0 Then
                GoTo 10
            Else
                Cells(i, "C") = say
            End If
        Next
    Application.ScreenUpdating = True
End Sub

 

[Tevfik_Kursun]

Sayın Yusuf44 Hocam,
GoTo 10 derken 10: ifadesini say = ... dan önceye koyarak D1=0 elde edildi. Fark 30 dan büyük olsun kısmı çözmek lazım. Umarım onu da halledebilirim.
Saygılarımla

 

[YUSUF44]

Haklısınız, excel donup geri başladıktan sonra kodu düzenlerken unutmuşum. Yukarda düzelttim.

İkinci kısım çok zor. Dediğim gibi herhangi bir anda son sayı ile kalan sayı(lar) arasında 30 sayıdan fazla fark varsa o şart sağlanamayacağından sonsuz döngüye girip makro kilitlenir.

Örneğin herhangi bir anda son yazılan 150 olsun ve kalan sayılar da 181, 182, 183, 200, 260, 450, 100, 70 olsun. Bu durumda makronun sonlanması mümkün olmaz.

 

[Tevfik_Kursun]

Merhaba,
İlginize çok teşekkür ederim.

if ile başlayan satırı
            If WorksheetFunction.CountIf(Range("C2:C" & i), say) > 0 Or _
            (Cells(Range("C" & i), say) - Cells(Range("C" & i - 1), say)) > 30 Then

bununla değiştirdiğimde resimdeki hata geliyor. Dediğiniz gibi son kalan 20 değeri yerleştiremezse, yerleşemeyenler F3 ten itibaren sıralanırsa konu manuel olarak ta çözülebilir. Yine de bakalım.
Saygılarımla

 

[veyselemre]

Sub deneme()
    Dim i As Integer, al As Integer, getir As Integer, say As Integer
    Dim wf As Object, dic As Object, lst
    Set dic = CreateObject("Scripting.Dictionary")
    Set wf = WorksheetFunction
enbas:
    Range("C3:C462").Clear

    For i = 1 To 460
        dic(i) = i
    Next i

    For i = 3 To 462
        say = 0
tekrar:
        lst = dic.items
        al = wf.RandBetween(1, dic.Count)
        getir = lst(al - 1)
        If Abs(getir - Cells(i - 1, 3).Value) > 30 Then
            Cells(i, 3).Value = getir
            dic.Remove getir
        Else
            say = say + 1
            If say > 5 Then GoTo enbas
            GoTo tekrar
        End If
    Next i
End Sub

 

[Tevfik_Kursun]

Sayın Veysel Emre,
İlginize çok teşekkür ederim. Tam beklediğim gibi.
Saygılarımla