İki sütunu rastgele dağıtabilir miyiz?

[tektonik]

Sayın ustalarım ekteki örnekte, A ve B sütunundaki verileri, E ve F sütununa rastgele dağıtabilir miyiz?

 

[leumruk]

Merhaba,

Sub karistir()
Dim Sec() As Variant
Sor = Application.InputBox("Kaç sütun karıştırılsın? En fazla 3 sütun seçebilirsiniz.")
If Sor = False Or Sor = "" Or Not IsNumeric(Sor) Then Exit Sub
If Sor > 3 Then MsgBox "Geçersiz değer...", vbCritical: Exit Sub
Son = [a65536].End(3).Row
Range("e1:g" & Son).ClearContents
ReDim Sec(1 To Son * Sor)
Randomize
Application.ScreenUpdating = False
Set Aralik = Range(Cells(1, 1), Cells(Son, Int(Sor)))
For Each hcr In Aralik
tekrar:
Sayi = Int(((Son * Sor) * Rnd) + 1)
If Sec(Sayi) <> "" Then GoTo tekrar
If WorksheetFunction.CountIf(Range("i2:i" & [i65536].End(3).Row), hcr) > 0 Then
Sec(Sayi) = ""
Else:
Sec(Sayi) = hcr
End If
Next
For Each hcr2 In Range(Cells(1, 5), Cells(Son, 5 + Sor - 1))
y = y + 1
Cells(hcr2.Row, hcr2.Column) = Sec(y)
Next
End Sub

 

[Orion1]

Dosyanız ektedir.

Sub rastgele_59()
'evrengizlenqhotmail.com
'21.04.2011
Randomize Timer
Dim sut As Integer, sat As Long, i As Long, k As Integer
Dim col As Collection, hcr As Range, j As Integer
Set col = New Collection
Sheets("Sayfa1").Select
Range("E2:G65536").ClearContents
Application.ScreenUpdating = False
For sut = 1 To 3
    sat = Cells(65536, sut).End(xlUp).Row
    For i = 1 To sat
        If WorksheetFunction.CountIf(Range("M2:M65536"), Cells(i, sut).Value) = 0 Then
            col.Add Cells(i, sut).Value
        End If
    Next
Next
For Each hcr In Range("E1:G65536")
    If col.Count > 0 Then
        j = CInt(Int(Rnd() * col.Count) + 1)
        hcr.Value = col(j)
        col.Remove (j)
        Else
        Exit For
    End If
Next
Application.ScreenUpdating = True
MsgBox "rastgele sayılar dağıtıldı." & vbLf & "evrengizlen@hotmail.com" & vbLf & _
"21.04.2011", vbOKOnly + vbInformation
        
End Sub

 

[tektonik]

Sayın ustalarım, çok ama çok teşekkür ederim