sütundaki verileri kendi aralarında dağıt

[Muhammet Okumuş]

Değerli forum üyeleri;
Ekteki dosyada A1:H10 aralığında 80 tane ilimiz yer alıyor.
Sizleden istediğim bir buton ile bu sütundaki illeri rastgele dağıtmak.her sütun kendi sütununda dağıtılacak.yani a sütundaki iller a sütunundan başka sütunda yer almayacak

 

[Muhammet Okumuş]

leumruk hocam dosyayı inceleyebilir misiniz?

 

[hsayar]

http://www.excel.web.tr/f48/random-hucre-secme-t58576.html
20. mesajdan uyarlayabilirsiniz.

 

[hsayar]

sn mukomus Düzce sizin oralarda hala il ilan edilmedi mi?
şaka bir yana düzceyi unuttunuz mu veriler size 8 sütuna 10 satır olarak mı lazım. toto gibi birden 100 sütuna çıkmasın

 

[Muhammet Okumuş]

hsayar hocam benim istediğim sütunlardaki illeri kendi aralarında değiştirecek. a sütunundaki iller a sütununda b sütununda b sütununda iller b sütununda .... bu şekil sıralanacak

 

[hsayar]

aşağıdaki kodlar 8 sütuna 10 satır için yazılmış olup, diğer hallerde uyumsuzluk çıkarabilir.
bu arada rassal seçimlerl ilgili sorular arttı. iyiki rsn. ripekin fonksiyonu var kolayca hallediliyor.

Public Enum enCevap
  enCevapEvet
  enCevapHayır
End Enum
Sub Sütunları_Karıştır()
Dim Csf As Worksheet: Set Csf = ThisWorkbook.Worksheets("sayfa1")
Dim data As Variant
Dim snlTab() As Variant
Dim tabSnc() As Variant
With Csf
  For sut = 1 To 8
    snlTab = .Range(Cells(1, sut), Cells(10, sut))
    '----------------
    data = BenzersizRastgeleSayilar(10, 1, 10, 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 10
      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(10, sut)) = Empty
'    Stop
    .Range(Cells(1, sut), Cells(10, 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

 

[Muhammet Okumuş]

hsayar çok güzel olmuş.ama işlem bitince vba'yı açıyor ve stop sarı renkli oluyor.

 

[hsayar]

önüne ' koyarak stopu kapatınız.

 

[Muhammet Okumuş]

tamam hsayar bu kez oldu teşekkür ederim

 

[hsayar]

rica ederim.