Sayı Üretme

[kemalist]

arkadaşlar belirli hücrelerdeki sayıları başka hücrelere dğıtmak istiyorum.Örnek dosya ektedir.

 

[Ömer BARAN]

Merhaba.
Aşağıdaki kod'u kullanabilirsiniz.
Kod'u sayfanın kod bölümüne uygulayıp çalıştırınız.

Sub DAĞIT()
Dim k As Byte

10
Range("C:C").ClearContents
son = [B65536].End(3).Row
    k = 0
20
    a = WorksheetFunction.RandBetween(Cells(1, 6), Cells(7, 6))
    k = k + 1
    Cells(k, 3) = Cells(a, 7)
If WorksheetFunction.CountIf(Range("C1:C" & k), Cells(k, 3)) > [B][COLOR="Red"]9[/COLOR][/B] Then GoTo 10
If k < son Then GoTo 20

End Sub

Kod'un sonlarındaki 9 sayısı (kırmızı renkli), bir sayının en fazla tekrarlanma sıklığına ilişkin üst sınır oluyor.
Dağılımın mümkün olduğunca dengeli olması amacıyla eklenmiştir.
Elimizdeki 7 sayıyı 50 hücreye dağıtacağımıza göre bir sayının 7 ve fazlası kez tekrarlanması beklenen durumdur.
Bu üst sınırı 8 yaparsanız kod daha geç, 10 yaparsanız daha hızlı sonuç üretecektir.

Sayıların sırayla dağıtılmasını istemediğiniz için VBA bölümüne konu açtığınızı düşünerek bu şekilde kod gönderiyorum.

 

[muygun]

Merhaba;
Alternatif olsun inceleyin.
İyi çalışmalar.

 

[Ömer BARAN]

Sayın muygun'un dosyasına bakınca fark ettim ki; 20 satıra veri dağıtmak istemişsiniz, ben 50 satıra da dağıtılacak diye düşünmüştüm.

 

[kemalist]

Sayın muygun'un dosyasına bakınca fark ettim ki; 20 satıra veri dağıtmak istemişsiniz, ben 50 satıra da dağıtılacak diye düşünmüştüm.

Sayın Baran benim de istediğm 50 satırdı hem size hemde muygun'a ilginizden dolayı teşekkür ederim.İşlem tamam.
Şimdiyse sütunların yerini değiştirdim.Buna göre Kodda nasıl bir değişiklik yapılabilir.
Dosya ektedir.

 

[Ömer BARAN]

Gönderdiğim kod'da Cells(SATIR NO, SÜTUN NO) şeklinde düşünerek değişiklik yapabilirsiniz.

 

[kemalist]

denedim fakat olmadı

 

[Ömer BARAN]

Kod'u aşağıdaki şekilde değiştirin.
Önceki kod'dan farklı olarak;
-- AC sütununa sayıların ilgili alanda kaç kez yer aldığını gösterir,
-- Kod, her sayı ilgili alanda en az 5 ve en çok 9 kez tekrarlanacak (bunları kırmızı olarak belirttim) şekilde çalışır.
5 ve 9 sayısını 50/7 = 7 (yaklaşık) sayısına göre +2, -2 gibi düşündüm, böylece dengeli dağılım elde etmek istedim.

Sub DAĞIT()
Dim k As Byte
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
10
Range("X:X").ClearContents
son = [W65536].End(3).Row
k = 0
20
    a = WorksheetFunction.RandBetween(Cells(1, 27), Cells(7, 27))
    k = k + 1
    Cells(k, 24) = Cells(a, 28)
If k < son Then GoTo 20
For a = 1 To 7
Cells(a, 29) = WorksheetFunction.CountIf(Range("X1:X" & son), Cells(a, 28))
Next
If WorksheetFunction.Min(Range("AC1:AC7")) < [B][COLOR="red"]5[/COLOR][/B] Or WorksheetFunction.Max(Range("AC1:AC7")) > [B][COLOR="Red"]9[/COLOR][/B] Then GoTo 10
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

 

[kemalist]

Teşekkürler Ömer Bey; sağlcakla kal....

 

[Ömer BARAN]

Teşekkürler Ömer Bey; sağlcakla kal....

Eyvallah, siz de sağlıcakla kalın.

 

[kemalist]

Kodda değişiklik yapabilirmiyiz? Örnek dosya ektedir.

 

[kemalist]

yardım edebilecek yok mu?

 

[kemalist]

Kodda değişiklik yapabilirmiyiz? Örnek dosya ektedir.

 

[Ömer BARAN]

Dosyanızda çalışan kod göremedim, kod içeren dosyayı yükler misiniz?

 

[kemalist]

Dosyanızda çalışan kod göremedim, kod içeren dosyayı yükler misiniz?

ilgili dosya ektedir.İlginiz için teşekkür ederim.

 

[Ömer BARAN]

Merhaba, yanlış anlamadıysam; belge açıkken alt taraftan sayfa adına sağ tıklayıp
KOD GÖRÜNTÜLEyi seçin ve açılan ekranda sağ tarafta kendi kodlarınızı görürsünüz, o kodların üstüne aşağıdaki
kod blokunu ekleyin, ayrıca kendi kodlarınızdaki kırmızı yeri aşağıdaki a =WorksheetFunction.... satırındaki
19 sayısını 2 olarak değiştirdikten sonra, AA1 ve AA2 hücrelerinde değişiklik yapınca kod otomatik olarak çalışacaktır.

[B]Private Sub Worksheet_Change(ByVal Target As Range)[/B]
If Intersect(Target, Range("[B][COLOR="Red"]AA1, AA2[/COLOR][/B]")) Is Nothing Then Exit Sub
    Call rastgeletamsayı
[B]End Sub[/B]

 

[kemalist]

Merhaba, yanlış anlamadıysam; belge açıkken alt taraftan sayfa adına sağ tıklayıp
KOD GÖRÜNTÜLEyi seçin ve açılan ekranda sağ tarafta kendi kodlarınızı görürsünüz, o kodların üstüne aşağıdaki
kod blokunu ekleyin, ayrıca kendi kodlarınızdaki kırmızı yeri aşağıdaki a =WorksheetFunction.... satırındaki
19 sayısını 2 olarak değiştirdikten sonra, AA1 ve AA2 hücrelerinde değişiklik yapınca kod otomatik olarak çalışacaktır.

[B]Private Sub Worksheet_Change(ByVal Target As Range)[/B]
If Intersect(Target, Range("[B][COLOR="Red"]AA1, AA2[/COLOR][/B]")) Is Nothing Then Exit Sub
    Call rastgeletamsayı
[B]End Sub[/B]

iki kodu birleştirirmisiniz?
Sub rastgeletamsayı()
Dim k As Byte

10
Range("X:X").ClearContents
son = [W65536].End(3).Row
k = 0
20
a = WorksheetFunction.RandBetween(Cells(1, 27), Cells(19, 27))
k = k + 1
Cells(k, 24) = Cells(a, 28)
If WorksheetFunction.CountIf(Range("X1:X" & k), Cells(k, 3)) > 9 Then GoTo 10
If k < son Then GoTo 20
End Sub

 

[Ömer BARAN]

20
a = WorksheetFunction.RandBetween(Cells(1, 27), Cells(19, 27))

Yukarıdaki cevabımda tam anlatamadım demekki. 19 sayısını 2 olarak değiştirin ve mevcut kodlarınızın üstüne bir önceki cevapta yer alan kod'u aynen yapıştırın.