randomize hücre

[multivizyon]

A1:H52 arasındaki Hücrelerin butona bastıgımda ; K1:K416 ya RANDOMİZE aktarılmasını isitoyrum bunu nasıl yapabilirim ?

Hücre renkleri bozulmamalı ..

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz.

Private Sub CommandButton1_Click()
    Dim Satir As Integer, Sutun As Byte
    Dim Veri As Collection, X As Integer
    Dim Adres As Variant
 
    Application.ScreenUpdating = False
 
    Set Veri = New Collection
 
    Range("K1:K416").Clear
 
10  Randomize Timer
 
    Satir = Int(52 * Rnd + 1)
    Sutun = Int(8 * Rnd + 1)
 
    On Error Resume Next
    X = X + 1
    Veri.Add Cells(Satir, Sutun).Address, CStr(X)
    On Error GoTo 0
 
    If Veri.Count < 416 Then
        GoTo 10
    Else
        X = 0
        For Each Adres In Veri
            X = X + 1
            Range(Adres).Copy Range("K" & X)
        Next
    End If
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[multivizyon]

Korhan bey ;
k1:k416 arasına 12 tane kadar kagıt geliyor 416 kagıdın hepsi gelmeli random şekilde ;

olursa tam istediğim gibi olucak ..

 

[Korhan Ayhan]

Merhaba,

Kodu deneyerek foruma eklemiştim. Tekrar kontrol ediniz.

 

[multivizyon]

tamamdır koyhan bey eline sağlık

 

[multivizyon]

tamamdır korhan bey eline sağlık .....

 

[Orion1]

alternatif.
Dosya ektedir.

Sub rastgelekagıt59()
Randomize Timer
Dim col As Collection, sat As Long, i As Long
sat = Cells(Rows.Count, "A").End(xlUp).Row
Set col = New Collection
Range("K:K").ClearContents
For i = 1 To sat
    col.Add Cells(i, "A").Value
Next i
Do While col.Count >= 1
    say = say + 1
    deg = Int(Rnd() * col.Count) + 1
    Cells(say, "K").Value = col(deg)
    col.Remove (deg)
Loop
MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation

End Sub

 

[multivizyon]

sagolun .....