Sütunları karıştırma

[sevarc]

herkese kolay gelsin.
çözemediğim bir işim vardı , yardımcı olursanız sevinirim.
ilk sütunda
A,B,C,D,..... diye isimler mevcut.
sonraki sütunlarda ise A'nın karşısında A1,A2,A3,... ; B'nin karşısında B1,B2,B3,... devam etmekte.
yapmak istediğim her satırda, örneğin A nın karşısında A2,A5,A1,... gibi sıralamayı değişirmek. hepsi rastgele olsun.
teşekkürler.

A A1 A2 A3 A4 ...
B B1 B2 B3 B4 ..
C C1 C2 C3 C4 ..

yağmak istediğim ise ,

A A2 A4 A3 A1
B B3 B1 B4 B2
C C1 C4 C3 C2 ..
yani rastgele olacak.

 

[Necdet]

Merhaba,

İlk sütun? A'mı B'mi, yoksa Z'mi?

Bu ilk sütunda belirttiğiniz A,B,C,D isimleri tek bir hücrede mi ?

Yani düşününce bu sorunun üzerinde çalışmak isteyen arkadaşın tüm hevesi kayboluyor. Belirsiz bir şey ile neden uğraşayım diye düşünür.

Örnek bir dosya ekleyiniz, soru net olsun.

 

[sevarc]

kusura bakmayın . iyi açıklayamadım galiba.
ama çözümü buldum başka yerde.
teşekkürler.

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 6
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
.Range(Cells(1, sut), Cells(10, sut)) = tabSnc
Erase snlTab, tabSnc, data
Next sut
End With
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
End Function

 

[sevarc]

herkese kolay gelsin.
çözemediğim bir işim vardı , yardımcı olursanız sevinirim.
ilk sütunda
A,B,C,D,..... diye isimler mevcut.
sonraki sütunlarda ise A'nın karşısında A1,A2,A3,... ; B'nin karşısında B1,B2,B3,... devam etmekte.
yapmak istediğim her satırda, örneğin A nın karşısında A2,A5,A1,... gibi sıralamayı değişirmek. hepsi rastgele olsun.
teşekkürler.

A A1 A2 A3 A4 ...
B B1 B2 B3 B4 ..
C C1 C2 C3 C4 ..

yağmak istediğim ise ,

A A2 A4 A3 A1
B B3 B1 B4 B2
C C1 C4 C3 C2 ..
yani rastgele olacak.