Kelimeleri rastgele yazdırma

[iskelet]

Selamlar,
Yapmak istediğim şey kelimeleri sayısı kadar rastgele yazdırmak
Dosya ektedir
Şimdiden teşekkürler

 

[leumruk]

Merhaba,
Sağlamasını yapınız.

Sub Rastgele()
Dim deg() As Variant
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set Aralik = s2.Range("a1:h8")
Aralik.ClearContents
Tpl = WorksheetFunction.Sum(s1.Range("b2:b" & s1.[b65536].End(3).Row))
If Tpl > Aralik.Count Then
MsgBox "Dağıtılacak miktar, dağıtılacak hücre sayısından fazla. Verilerinizi" & _
" kontrol ediniz.", vbCritical, "UYARI": Exit Sub
End If
ReDim deg(1 To Tpl)
For x = 2 To s1.[a65536].End(3).Row
If Val(Cells(x, "b")) > 0 Then
For y = 1 To Val(s1.Cells(x, "b"))
Say = Say + 1
deg(Say) = s1.Cells(x, "a")
Next
End If
Next
Randomize
For Each arl In Aralik
If Tpl > 0 Then
Sayi = Int((Tpl * Rnd) + 1)
s2.Cells(arl.Row, arl.Column) = deg(Sayi)
veri = deg(Tpl)
deg(Tpl) = deg(Sayi)
deg(Sayi) = veri
Tpl = Tpl - 1
End If
Next
MsgBox "İşlem tamamlanmıştır.", vbInformation, "Kodlayan: l e u m r u k"
End Sub

 

[iskelet]

Sayın leumruk,
Çok teşekkür ederim.
Ellerinize sağlık tam istediğim gibi olmuş.

 

[leumruk]

Sayın leumruk,
Çok teşekkür ederim.
Ellerinize sağlık tam istediğim gibi olmuş.

Rica ederim. İyi çalışmalar.

 

[leumruk]

Hücrenin boş olması durumunda ya da sayısal veri olmaması durumunda hatayla karşılaşmamanız için bir kaç kontrol satırı ekledim. Dosyayı yeni haliyle kullanabilirsiniz.