VBA ile belirli aralıktan belirli sayıda random hücre seçtirip değer atama

[seysek]

Merhabalar,

VBA ile belirli bir satır aralığından belirli bir hücredeki değer sayısınca rastgele hücre seçtirip hücrelerin içerisine "1" yazdırmak istiyoruz.

Örneğin; B1=5 olsun, A1:K1 hücre aralığından 5 adet rastgele hücre seçecek ve bu hücrelere "1" yazacak.

Yardımlarınız için şimdiden teşekkürler.

 

[YUSUF44]

A1:K1 aralığında B1 hücresi de vardır yalnız. Yani makro sonucunda B1'deki 5, 1 olarak değişir.

 

[YUSUF44]

Eğer B1 yerine A2'de yazan kadar hücreye rastgele 1 yazdırmak isterseniz aşağıdaki makroyu kullanabilirsiniz:

Sub rasgele()
If [A2] = "" Then
    MsgBox "Önce A2'ye 1-11 arası sayı giriniz!", vbInformation
    [A2].Select
    Exit Sub
ElseIf IsNumeric([A2]) Then
    If Int([A2]) > 11 Then
        [A1:K1] = 1
    Else
        say = Int([A2])
        [A1:K1].ClearContents
        For i = 1 To say
10:
            sut = WorksheetFunction.RandBetween(1, 11)
            If Cells(1, sut) <> "" Then
                GoTo 10
            Else
                Cells(1, sut) = 1
            End If
        Next
    End If
Else
MsgBox "Önce A2'ye 1-11 arası sayı giriniz!", vbInformation
    [A2].Select
    Exit Sub
End If
End Sub

 

[seysek]

Sorumu "A1:K1 satır aralığından" olarak düzeltiyorum, düzeltme için teşekkürler.

 

[seysek]

Eğer B1 yerine A2'de yazan kadar hücreye rastgele 1 yazdırmak isterseniz aşağıdaki makroyu kullanabilirsiniz:

Sub rasgele()
If [A2] = "" Then
    MsgBox "Önce A2'ye 1-11 arası sayı giriniz!", vbInformation
    [A2].Select
    Exit Sub
ElseIf IsNumeric([A2]) Then
    If Int([A2]) > 11 Then
        [A1:K1] = 1
    Else
        say = Int([A2])
        [A1:K1].ClearContents
        For i = 1 To say
10:
            sut = WorksheetFunction.RandBetween(1, 11)
            If Cells(1, sut) <> "" Then
                GoTo 10
            Else
                Cells(1, sut) = 1
            End If
        Next
    End If
Else
MsgBox "Önce A2'ye 1-11 arası sayı giriniz!", vbInformation
    [A2].Select
    Exit Sub
End If
End Sub

Sorumu "A1:K1 satır aralığından" olarak düzeltiyorum. Buna göre makroyu nasıl güncelleyebiliriz?

 

[YUSUF44]

Verdiğim makro A1:K1 aralığındaki hücrelere, A2'deki sayı kadar rastgele 1 yazıyor. Siz farklı bir şey mi istiyorsunuz?

 

[seysek]

Verdiğim makro A1:K1 aralığındaki hücrelere, A2'deki sayı kadar rastgele 1 yazıyor. Siz farklı bir şey mi istiyorsunuz?

Kusura bakmayın, yanlış anlamışım. Tam olarak ihtiyacımı gördü, çok teşekkürler.

 

[YUSUF44]

Eğer aşağıdaki kodları sayfanın kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırısanız A2 hücresini her değiştirdiğinizde istediğiniz işlem gerçekleşir:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A2]) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
If [A2] = "" Then
    MsgBox "Önce A2'ye 1-11 arası sayı giriniz!", vbInformation
    [A2].Select
    Exit Sub
ElseIf IsNumeric([A2]) Then
    If Int([A2]) > 11 Then
        [A1:K1] = 1
    Else
        say = Int([A2])
        [A1:K1].ClearContents
        For i = 1 To say
10:
            sut = WorksheetFunction.RandBetween(1, 11)
            If Cells(1, sut) <> "" Then
                GoTo 10
            Else
                Cells(1, sut) = 1
            End If
        Next
    End If
Else
    MsgBox "Önce A2'ye 1-11 arası sayı giriniz!", vbInformation
    [A2].Select
    Exit Sub
End If
End Sub

 

[seysek]

Eğer aşağıdaki kodları sayfanın kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) yapıştırısanız A2 hücresini her değiştirdiğinizde istediğiniz işlem gerçekleşir:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A2]) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
If [A2] = "" Then
    MsgBox "Önce A2'ye 1-11 arası sayı giriniz!", vbInformation
    [A2].Select
    Exit Sub
ElseIf IsNumeric([A2]) Then
    If Int([A2]) > 11 Then
        [A1:K1] = 1
    Else
        say = Int([A2])
        [A1:K1].ClearContents
        For i = 1 To say
10:
            sut = WorksheetFunction.RandBetween(1, 11)
            If Cells(1, sut) <> "" Then
                GoTo 10
            Else
                Cells(1, sut) = 1
            End If
        Next
    End If
Else
    MsgBox "Önce A2'ye 1-11 arası sayı giriniz!", vbInformation
    [A2].Select
    Exit Sub
End If
End Sub

Yanıtlarınız için çok teşekkürler. Yazdığınız kodları kendi dosyam için uyarlamaya çalıştım ama düzgün çalıştıramadım.
Bendeki A2 değeri "Data" sayfasındaki "AH8" hücresinde. Random doldurulacak hücreler de "Dashboard" sayfasında. Dashboard sayfasında doldurulacak hücreler 3 aralıktan oluşuyor. AH8 hücresindeki değer bu 3 aralığın toplamına dağıtılacak. Aralıklar; L26:T26, X26:BM26, BQ26:BY26. Yani AH8'de 20 yazıyorsa bu 3 aralıktaki 1'lerin toplamı 20 olacak. AH'ın maksimum değeri 60 olabilir. Yani AH'a 0'dan başlayarak hergün değerler girilecek. 60 değeri girildiğinde bu aralıktaki hücrelerin hepsi dolmuş olacak. Zaten 60 hücre var toplam. Bilmiyorum tam anlatabildim mi ama yardımcı olursanız çok sevinirim.

Son olarak AH8 boşsa uyarı vermeden direkt tüm hücreleri boş bırakacak.

 

[seysek]

Acil yardıma ihtiyacım var..

 

[YUSUF44]

İlk sorunuzla asıl isteğiniz arasında dağlar kadar fark var maalesef.

Asıl isteğinize uygun olarak hazırladığım aşağıdaki kodlar maalesef exceli donduruyor:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [AH8]) Is Nothing Then Exit Sub
Set s1 = Sheets("Dashboard")
If Target = "" Then
    s1.[L26:T26, X26:BM26, BQ26:BY26].ClearContents
    Target.Select
    Exit Sub
ElseIf IsNumeric(Target) Then
    If Int(Target) > 60 Then
        s1.[L26:T26, X26:BM26, BQ26:BY26] = 1
        Target.Select
        s1.Activate
    Else
        say = Int(Target)
        Application.ScreenUpdating = False
           a = 1
           Do Until a > say
10:
   
                sut = WorksheetFunction.RandBetween(1, 60)
                If sut < 10 Then
                    sut = sut + 11
                ElseIf sut > 9 And sut < 52 Then
                    sut = sut + 24
                Else
                    sut = sut + 69
                End If
                If s1.Cells(26, sut) <> "" Then
                    GoTo 10
                Else
                    s1.Cells(26, sut) = 1
                End If
                a = a + 1
            Loop
        Application.ScreenUpdating = True
        Target.Select
        s1.Activate
    End If
Else
    MsgBox "Önce AH8'e 1-11 arası sayı giriniz!", vbInformation
    Target.Select
    Exit Sub
End If
End Sub