Harfleri verilen sayı kadar rastge yerleştirme

[iskelet]

Selamlar
Yapmak istediğim şey ekte belirtilmiştir. Yardımcı olabilecek arkadaşlara şimdiden teşekkürler.

 

[Orion1]

Dosyanız ektedir.

Sub rastgele_sayi_59()
Dim i As Long, col As Collection, k As Byte, sut As Byte, j As Byte
Dim indis As Byte, toplam As Integer
Randomize Timer
Sheets("Sayfa1").Select
sut = Cells(1, "IV").End(xlToLeft).Column
Application.ScreenUpdating = False
Range("A8:IV65536").ClearContents
For i = 2 To 4
    Set col = New Collection
    toplam = WorksheetFunction.Sum(Range(Cells(i, "A"), Cells(i, sut)))
    If toplam > 254 Then
        MsgBox i & " Satırında Toplam sayı 254 ü geçiyor." & i & " satır  işleme sokulmadı.", vbCritical, "UYARI"
        GoTo atla:
    End If
    For k = 1 To toplam
        For j = 1 To Cells(i, k).Value
            col.Add Cells(1, k).Value
        Next j
    Next k
    For k = 1 To toplam
        indis = Int(Rnd() * col.Count) + 1
        Cells(i + 6, k).Value = col(indis)
        col.Remove (indis)
    Next k
atla:
    Set col = Nothing
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamadır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[iskelet]

Sayın Evren Bey,
Ellerinize sağlık çok güzel olmuş.
Acaba Harflerin altındaki sayılara 3 satır daha eklesem koda ne eklemem gerekiyor.
Teşekkürler.

 

[Orion1]

Sayın Evren Bey,
Ellerinize sağlık çok güzel olmuş.
Acaba Harflerin altındaki sayılara 3 satır daha eklesem koda ne eklemem gerekiyor.
Teşekkürler.

Sadece aşağıdaki değişiklik yeteridir.

For i = 2 To [B][COLOR="Red"]7[/COLOR][/B]

 

[iskelet]

Evren Bey denedim ama hata verdi nerde yanlış yaptım acaba.

 

[Orion1]

Evren Bey denedim ama hata verdi nerde yanlış yaptım acaba.

Benim yazdığım email adresini silin.

 

[iskelet]

Evren Bey çok teşekkür ederim. Elleriniz dert görmesin. Sağlıcakla kalın.

 

[Orion1]

Evren Bey çok teşekkür ederim. Elleriniz dert görmesin. Sağlıcakla kalın.

Rica ederim.
İyi çalışmalar.

 

[iskelet]

Selamlar Sayın Evren Bey,
Biz yukarıdaki dosyada satıra yazdırmıştık. Acaba bu işlemi sütuna yazdırabilir mi? Yani A harfinin altındaki rakamı satıra değilde sütuna yazdırmak mümkün mü?

 

[Orion1]

Selamlar Sayın Evren Bey,
Biz yukarıdaki dosyada satıra yazdırmıştık. Acaba bu işlemi sütuna yazdırabilir mi? Yani A harfinin altındaki rakamı satıra değilde sütuna yazdırmak mümkün mü?

Dosyanız ektedir.

Sub rastgele_sayi_Dikey_59()
Dim i As Long, col As Collection, k As Byte, sut As Byte, j As Byte
Dim indis As Byte, toplam As Integer
Randomize Timer
Sheets("Sayfa1").Select
sut = Cells(1, "IV").End(xlToLeft).Column
Application.ScreenUpdating = False
Range("A10:O65536").ClearContents
For i = 2 To 4
    Set col = New Collection
    toplam = WorksheetFunction.Sum(Range(Cells(i, "A"), Cells(i, sut)))
    If toplam > 254 Then
        MsgBox i & " Satırında Toplam sayı 254 ü geçiyor." & i & " satır  işleme sokulmadı.", vbCritical, "UYARI"
        GoTo atla:
    End If
    For k = 1 To toplam
        For j = 1 To Cells(i, k).Value
            col.Add Cells(1, k).Value
        Next j
    Next k
    For k = 1 To toplam
        indis = Int(Rnd() * col.Count) + 1
        Cells(k + 10, i - 1).Value = col(indis)
        col.Remove (indis)
    Next k
atla:
    Set col = Nothing
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamadır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[iskelet]

Sayın Evren Bey,
Çok teşekkür ederim. Ellerinize sağlık.

 

[iskelet]

Sayın Evren Bey,
Çok teşekkür ederim. Ellerinize sağlık.

 

[Orion1]

Sayın Evren Bey,
Çok teşekkür ederim. Ellerinize sağlık.

Rica ederim.
İyi çalışmalar.