Ortalamayı bozmadan rasgele sayı yerleştirme ?

[Gorarr]

Selamlar burda yapamadığım olay şu şekilde;

C sütunundaki boş hücrelere rasgele sayılar gelmesi gerekiyor ancak.

Bu rasgele sayıların şuan girili olan sayıların en küçüğü ile en büyüğü arasında olması gerekiyor,
Şuan ki örnek için "1 - 34" arasında rasgele sayıların boş yerlere rasgele gelmesi gerekiyor.

Yardımlarınız için şimdiden çok çok teşekkür ederim..

 

[omerceri]

Sn Gorarr
Ortalama bozulmayacaksa, ortalamayı yazmak durumundasın, rastgele sayıya ne gerek var. Yada sorunuzu biraz açın

 

[Gorarr]

Hocam ilgilendiğiniz için teşekkür ederim.

Yaptığım mantık hatasını anladım. Sorumu ve örnek dosyamı yenileyip daha net bir biçimde tekrar sordum.

 

[omerceri]

Sn Gorarr
Aşağıdaki kodu Modül ünüze yapıştırın. Bu makroyu Düğmenize atayın.
Sub a()
say = Range("b1").CurrentRegion.Rows.Count
For e = 1 To say
If Range("C" & e) = "" Then
Range("C" & e).Value = Int((34 * Rnd) + 1)
End If
Next
End Sub

 

[leumruk]

Merhaba,
Eki inceleyiniz.

Sub Rastgele()
If WorksheetFunction.CountIf(Range("c2:c" & [b65536].End(3).Row), "") = 0 Then Exit Sub
Set Aralik = Range("c2:c" & [b65536].End(3).Row).SpecialCells(xlCellTypeBlanks)
En_Buyuk = WorksheetFunction.Large(Range("c2:c" & [b65536].End(3).Row), 1)
En_Kucuk = WorksheetFunction.Small(Range("c2:c" & [b65536].End(3).Row), 1)
Randomize
For Each hcr In Aralik
sayi = Int(Rnd() * (En_Buyuk - En_Kucuk) + 1) + En_Kucuk
Cells(hcr.Row, hcr.Column) = sayi
Next
End Sub

 

[Muhammet Okumuş]

Sub ata()
a = WorksheetFunction.Max(Range("c1:c1000"))
b = WorksheetFunction.Min(Range("c1:c1000"))
c = (a - b) - 1
For i = 1 To [b1000].End(3).Row
Randomize Timer
x = Int(Rnd() * c + 1) + b
If Cells(i, 3) <> "" Then GoTo 10
Cells(i, 3) = x
10
Next i
End Sub

sn ömerceri ve leumruk cevap vermiş. benim çalışmam da boşa gitmesin diye ekledim.

 

[omerceri]

Sonradan Yukardaki kodumun eksik olduğunu anladım. Aşağıdaki kodu kullanın
Sub a()
say = Range("b1").CurrentRegion.Rows.Count
K = Application.Min(Range("C1:C" & say))
B = Application.Max(Range("C1:C" & say))
For e = 1 To say

If Range("C" & e) = "" Then
Counter = Int(((B) * Rnd) + 1)
While Counter < K
Counter = Int(((B) * Rnd) + 1)

Wend
Range("C" & e).Value = Counter
End If
Next
End Sub

 

[Gorarr]

Akşam acil işim çıktı daha yeni bakabildim. Hepinizede çok teşekkür ederim. Tam istediğim gibi olmuş elerinize sağlık. Konuyla ilgili bir ihtiyacım daha oldu onuda burda sorsam.

Örneğin C sütununda sayılar değilde yazılar olsa yine boş hücrelere bulunan kelimelerden rasgele gelmesi sağlanabilirmi. Bu konudada yardımcı olabilirseniz çok memnun kalıcam. "Örnek dosyamıda yeniledim." Tekrardan teşekkürler...

 

[Muhammet Okumuş]

Sub ata2()
Application.ScreenUpdating = False
For i = 2 To [b2000].End(3).Row
If Cells(i, 3) = "" Then GoTo 10
If WorksheetFunction.CountIf(Range("c2:c" & i), Cells(i, 3)) = 1 Then Cells([d2000].End(3).Row + 1, 4) = Cells(i, 3)
10
Next i
For j = 2 To [b2000].End(3).Row
If Cells(j, 3) <> "" Then GoTo 20
Randomize Timer
b = WorksheetFunction.CountA(Range("d2:d2000"))
y = Int(Rnd() * b + 1)
Cells(j, 3) = Cells(y+1 , 4)
20
Next j
Range("d2:d2000") = ""
End Sub

kodu deneyiniz.

 

[Gorarr]

muokumus hocam teşekkür ederim. Bir şey ilgimi çekti kod başarılı bir şekilde çalışıyor ama bir tıklama yetmiyor, 2 tıklamada tüm boş hücreleri dolduruyor. Aceba bu neden olabilir. Teşekkürler..

 

[leumruk]

Merhaba,
Ekteki dosyaya bir de boşaltma düğmesi ekledim. Bu düğme listeyi eski haline çevirir.

Sub Rastgele()
Dim deg() As Variant
If WorksheetFunction.CountIf(Range("c2:c" & [b65536].End(3).Row), "") = 0 Then Exit Sub
Dolu = WorksheetFunction.CountA(Range("c2:c" & [b65536].End(3).Row))
If Dolu = 0 Then Exit Sub
Set Aralik_Dolu = Range("c2:c" & [b65536].End(3).Row).SpecialCells(xlCellTypeConstants, 23)
ReDim deg(1 To Dolu)
For Each hcr In Aralik_Dolu
Say = Say + 1
deg(Say) = hcr
Next
Randomize
Set Aralik = Range("c2:c" & [b65536].End(3).Row).SpecialCells(xlCellTypeBlanks)
For Each hcr In Aralik
sayi = Int(Rnd() * Say + 1)
Cells(hcr.Row, hcr.Column) = deg(sayi)
Next
End Sub

 

[Muhammet Okumuş]

Tek tıklamada dolduryor.

Cells(j, 3) = Cells(y+1 , 4)

bu şekilde düzeltmiştim.Bunu değiştiriniz.

 

[Gorarr]

Hepinize çok çok teşekkür ederim. Bu konu ile ilgili tüm işlemlerim halloldu. Saygılar selamlar..

"leumruk hocam alternatif örnek için sizede çok teşekkür ederim."