Excelde verileri makro ile Randomize etmek

[DeViaNce]

A1:A100 arasında 1 den 100 e kadar sıralı rakamlar var ben bunları bir makroyla düzensiz olarak A1:A100 aralığında kayıpsız olarak karıştırmak istiyorum yani

A1 : 1 4
A2 : 2 3
A3 : 3 2
A4 : 4 5
A5 : 5 1

Teşekkürler...

 

[hsayar]

inceleyiniz........
http://www.excel.web.tr/f48/sutundaki-verileri-kendi-aralar-nda-dag-t-t58596.html

 

[hsayar]

kodları biraz daha genelledim.

Public Enum enCevap
  enCevapEvet
  enCevapHayır
End Enum
Sub Sütunları_Karıştır()
'Belirtilen sayfada, Sut Sutundaki 1 ila sonVeriSat aralığındaki
'Değerleri randomize olarak karıştırır.
Dim Csf As Worksheet: Set Csf = ThisWorkbook.Worksheets("hsr")
Dim data As Variant
Dim snlTab() As Variant
Dim tabSnc() As Variant
Dim sonVeriSat As Long
sonVeriSat = 100

With Csf
  For sut = 1 To 1
    snlTab = .Range(Cells(1, sut), Cells(sonVeriSat, sut))
    '----------------
    data = BenzersizRastgeleSayilar(sonVeriSat, 1, sonVeriSat, enCevapHayır)
    If TypeName(data) = "Boolean" Then
      MsgBox "BenzersizRastgeleSayilar fonksiyonu için verdiğiniz KacAdetSayi, EnKucukSayi, EnBuyukSayi değerlerinden bir veya daha fazlası uyumsuzdur."
      Exit Sub
    End If
    '----------------------------
    For sat = 1 To sonVeriSat
      ii = ii + 1
      ReDim Preserve tabSnc(1 To 1, 1 To ii)
      tabSnc(1, ii) = snlTab(data(sat), 1)
    Next sat
    ii = 0
     tabSnc = Application.Transpose(tabSnc)
    .Range(Cells(1, sut), Cells(sonVeriSat, sut)) = Empty
'    Stop
    .Range(Cells(1, sut), Cells(sonVeriSat, sut)) = tabSnc
    Erase snlTab, tabSnc, data
  Next sut
End With
'Stop
Set Csf = Nothing
End Sub
Function BenzersizRastgeleSayilar(KacAdetSayi As Long, EnKucukSayi As Long, EnBuyukSayi As Long, Optional Sıralımı As enCevap) As Variant
'Benzersiz Rastgele Sayılar Üretir.
'Kullanımı Aşağıdaki gibidir
'Data = UniqueRandomNumbers(6, 1, 49)
Dim RandColl As Collection, varTemp() As Long
Dim k&, i&, j&
BenzersizRastgeleSayilar = False

If KacAdetSayi < 1 Then Exit Function
If EnKucukSayi > EnBuyukSayi Then Exit Function
If KacAdetSayi > (EnBuyukSayi - EnKucukSayi + 1) Then Exit Function
Set RandColl = New Collection
Randomize
Do
On Error Resume Next
i = CLng(Rnd * (EnBuyukSayi - EnKucukSayi) + EnKucukSayi)
RandColl.Add i, CStr(i)
On Error GoTo 0
Loop Until RandColl.Count = KacAdetSayi

ReDim varTemp(1 To KacAdetSayi)

For i = 1 To KacAdetSayi
varTemp(i) = RandColl(i)
Next i
Set RandColl = Nothing

If Sıralımı = enCevapEvet Then
  '**************ripek********************
  For i = 1 To KacAdetSayi - 1
      For j = i + 1 To KacAdetSayi
          If varTemp(i) > varTemp(j) Then
              k = varTemp(i)
              varTemp(i) = varTemp(j)
              varTemp(j) = k
          End If
      Next j
  Next i
  '**************ripek********************
End If
BenzersizRastgeleSayilar = varTemp
Erase varTemp
k = 0: i = 0: j = 0
'*****www.excel.web.Tr***********
End Function

 

[DeViaNce]

Teşekkür Ederim...

 

[hsayar]

Teşekkür Ederim...

Rica ederim

 

[hsayar]

Genelleme olması ve uyarlama kolylığı için biraz geliştirme yaptım.

Yeni Bir MOdul ekleyiniz ve adını ModFonk Yapınız.

Public Enum enCevap
  enCevapEvet
  enCevapHayır
End Enum
Function BenzersizRastgeleSayilar(KacAdetSayi As Long, EnKucukSayi As Long, EnBuyukSayi As Long, Optional Sıralımı As enCevap) As Variant
'Benzersiz Rastgele Sayılar Üretir.
'Kullanımı Aşağıdaki gibidir
'Data = UniqueRandomNumbers(6, 1, 49)
Dim RandColl As Collection, varTemp() As Long
Dim k&, i&, j&
BenzersizRastgeleSayilar = False

If KacAdetSayi < 1 Then Exit Function
If EnKucukSayi > EnBuyukSayi Then Exit Function
If KacAdetSayi > (EnBuyukSayi - EnKucukSayi + 1) Then Exit Function
Set RandColl = New Collection
Randomize
Do
On Error Resume Next
i = CLng(Rnd * (EnBuyukSayi - EnKucukSayi) + EnKucukSayi)
RandColl.Add i, CStr(i)
On Error GoTo 0
Loop Until RandColl.Count = KacAdetSayi

ReDim varTemp(1 To KacAdetSayi)

For i = 1 To KacAdetSayi
varTemp(i) = RandColl(i)
Next i
Set RandColl = Nothing

If Sıralımı = enCevapEvet Then
  '**************ripek********************
  For i = 1 To KacAdetSayi - 1
      For j = i + 1 To KacAdetSayi
          If varTemp(i) > varTemp(j) Then
              k = varTemp(i)
              varTemp(i) = varTemp(j)
              varTemp(j) = k
          End If
      Next j
  Next i
  '**************ripek********************
End If
BenzersizRastgeleSayilar = varTemp
Erase varTemp
k = 0: i = 0: j = 0
'*****www.excel.web.Tr***********
End Function

Yeni Bir MOdul ekleyiniz ve adını ModIslm Yapınız.

Option Explicit
Sub Sütunları_Karıştır()
Dim Csf As Worksheet: Set Csf = ThisWorkbook.Worksheets("hsr")
Dim rngGiris As Range, sut As Long
With Csf
  For sut = 1 To 6
    Set rngGiris = .Range(.Cells(1, sut), .Cells(100, sut))
    Call PrSubSütunlarıKarıştır(rngGiris, rngGiris)
  Next sut
End With
Set Csf = Nothing
End Sub
Sub PrSubSütunlarıKarıştır(rngGiris As Range, rngCikis As Range)
Dim data As Variant
Dim snlTab() As Variant
Dim tabSnc() As Variant
Dim ii As Long, sat As Long
snlTab = rngGiris
'\\ Karıştırılacak verilerin index nolarını alıyoruz.
  data = BenzersizRastgeleSayilar(UBound(snlTab), LBound(snlTab), UBound(snlTab), enCevapHayır)
  If TypeName(data) = "Boolean" Then
    MsgBox "BenzersizRastgeleSayilar fonksiyonu için verdiğiniz KacAdetSayi, EnKucukSayi, EnBuyukSayi değerlerinden bir veya daha fazlası uyumsuzdur."
    Exit Sub
  End If
'\\ Elemanları İndex numaralarından tabSnc Dizisine atıyoruz.
    ii = 0
    For sat = LBound(snlTab) To UBound(snlTab)
      ii = ii + 1
      ReDim Preserve tabSnc(1 To 1, 1 To ii)
      tabSnc(1, ii) = snlTab(data(sat), 1)
    Next sat
'\\ tabSnc Dizisini Çalışma sayfasına geri veriyoruz.
    rngCikis = Empty
    rngCikis = Application.Transpose(tabSnc)
'\\ Değişknelerimizi siliyoruz.
Erase snlTab, tabSnc, data
Set rngGiris = Nothing
Set rngCikis = Nothing
End Sub