Rastgele Satır Karıştırma (özel koşul ile)

[meslek5]

Merhaba değerli hocalarım, içinden çıkamadığım bir çalışma için sizden bir ricada bulunmak istiyorum. Şuana kadar bu sitedeki uzman arkadaşlardan özellikle de (Yusuf44) beyden bir çok konuda yardım aldım ve bunun için çok çok teşekkür ederim. Ekte yer alan dosyada bir adet tablo var ve bu tablo içinde yan yana hücrelerde olan aynı kelimeler veya sayılar (yani değeri aynı olan yan yana hücreler) birlikte taşınmak kaydıyla söz konusu tabloyu yatay olarak rastgele karıştırabilir miyiz? Hücreler yatay olarak karıştırılırken örneğin; "C4" ve "D4" hücreleri birbirleri ile aynı değere sahip ve tablo rastgele karıştırılırken bu hücreler ve buna benzer hücreler ikili olarak karıştırılacak yani sağındaki veya solundaki aynı değere sahip hücre ile taşınacak. Eğer hücrenin değeri sağındaki veya solundaki hücre ile aynı değilse bu hücre tek başına karıştırılacak. Daha anlaşılır olması için Örnek dosyada Satır-1'in rastgele örnek karıştırmasını elle yaptım.

Böyle bir şey mümkün ise ve bana bu konuda yardım edebilirseniz minnettar olurum. Şimdiden çok teşekkür ederim.

ÖRNEK DOSYA

İndir ÖRNEK DOSYAM

Dosyayı indir ÖRNEK DOSYAM

dosya.co

 

[ÖmerFaruk]

Bazı değerleri sanki şartmışçasına ard arda getirmişsiniz. Mesela başlık 6 ve 7 deki 2-2 değerleri başlık 11-12 ye yine ardı ardına gelmiş.
Böyle bir kısıt var mı?

 

[meslek5]

Bazı değerleri sanki şartmışçasına ard arda getirmişsiniz. Mesela başlık 6 ve 7 deki 2-2 değerleri başlık 11-12 ye yine ardı ardına gelmiş.
Böyle bir kısıt var mı?

Hayır hocam öyle denk gelmiş başlığa göre bir kısıt yok

 

[meslek5]

Bazı değerleri sanki şartmışçasına ard arda getirmişsiniz. Mesela başlık 6 ve 7 deki 2-2 değerleri başlık 11-12 ye yine ardı ardına gelmiş.
Böyle bir kısıt var mı?

Hocam bunun çözümü varmı yardımcı olabilir misiniz?

 

[Muhammet Okumuş]

Sub Karıştır()
Application.ScreenUpdating = False
Range("Y4:Y23") = "=IF(X4=""+"",1,RAND())"
Range("Z4:Z23") = "=IF(W4="""","""",IF(W4=""+"",""+"",OFFSET(X$3,ROW(A1)-COUNTIF(W$4:W4,""+""),0)))"
For i = 4 To 23
Range("W4:X23") = Application.Transpose(Range("C" & i & ":V" & i))

Range("X4:Y23").Sort Range("Y4"), 1
'Exit Sub
Range("C" & i & ":V" & i) = Application.Transpose(Range("Z4:Z23"))

Next
Range("W4:Z23") = ""
End Sub

Kodu dedeneyiniz. W:Z sütunlarında işlem yapıyor.

 

[meslek5]

Sub Karıştır()
Application.ScreenUpdating = False
Range("Y4:Y23") = "=IF(X4=""+"",1,RAND())"
Range("Z4:Z23") = "=IF(W4="""","""",IF(W4=""+"",""+"",OFFSET(X$3,ROW(A1)-COUNTIF(W$4:W4,""+""),0)))"
For i = 4 To 23
Range("W4:X23") = Application.Transpose(Range("C" & i & ":V" & i))

Range("X4:Y23").Sort Range("Y4"), 1
'Exit Sub
Range("C" & i & ":V" & i) = Application.Transpose(Range("Z4:Z23"))

Next
Range("W4:Z23") = ""
End Sub

Kodu dedeneyiniz. W:Z sütunlarında işlem yapıyor.

Sayın hocam yardımınız için teşekkür ederim. Fakat bu kodlar yan yana olan benzer hücreleri birlikte taşıyarak karıştırmıyor. "C4:V23" aralığındaki her satırı kendi yatay düzeyinde ve yan yana olan benzer hücreleri birlikte taşıyarak karıştırması lazım

 

[Muhammet Okumuş]

6+6 olabilir mi? Aynı grubun icerisine + konulabilir mi?

 

[meslek5]

6+6 olabilir mi? Aynı grubun icerisine + konulabilir mi?

Hocam örnek dosyanın 13 nolu satırında örnek olsun diye elle karıştırma yaptım. Bunu yaparken şunlara dikkat ettim; Eğer yan-yana aynı değere sahip hücre varsa bu hücreleri karıştırırken yanındaki aynı değere sahip benzer hücre ile birlikte taşıdım. Ve değeri "+" olan hücrelere dokunmadım. Aslında buna şöyle diyebiliriz; satır içerisindeki hücreler yanındaki benzer hücre ile birlikte rastgele yer değiştirecek

İndir ÖRNEK DOSYAM

Dosyayı indir ÖRNEK DOSYAM

dosya.co

 

[meslek5]

Aslında yapılmak istenen çok açık, satırdaki hücreler rastgele karışacak ama 2 koşul var
1. Koşul= Yan-yana olup ta birbiri ile aynı değere sahip hücreler yanındaki hücre ile birlikte taşınarak karıştırılacak yani karışımın sonunda yine bu hücreler yan-yana gelecek
2. Koşul= Değeri "+" olan hücreler karıştırılmayacak ve sabit kalacak

Bunun kod ile mümkün olacağını zannediyorum.

 

[Muhammet Okumuş]

Mümkündür, mutlaka çözülür ama uğraşmak gerekiyor.

 

[meslek5]

Bu konuda uzman hocalarımdan yardım bekliyorum.

 

[halit3]

Sayfa1 de bu kodu bir dene

Sub deneme1()

son = 22
ilk = 3

ReDim deg1(son)
ReDim deg2(son)
ReDim deg3(son)
ReDim deg4(son)
ReDim deg5(son)
ReDim deg6(son)

For k = 4 To 23

sat1 = k
sat = 0
For j = ilk To son
If IsNumeric(Cells(sat1, j).Value) = True Then
sat = sat + 1
deg1(sat) = 0
deg2(sat) = 1
deg3(sat) = Cells(sat1, j).Value
deg4(sat) = 1
End If
Next j

For i = 1 To sat
atla:
say = Int((Rnd * sat) + 1)
If Val(deg1(say)) = 0 Then
deg1(say) = 1
deg5(i) = deg3(say)
Else
GoTo atla
End If
Next i

sat2 = ilk - 1

For r = 1 To sat
aranan1 = deg5(r)
If deg2(r) = 1 Then
For i = r To sat
If deg5(i) = aranan1 Then
deg2(i) = 0
deg6(sat2) = deg5(i)
sat2 = sat2 + 1
End If
Next i
End If
Next r

m = 0
For i = 1 To son
If IsNumeric(Cells(sat1, i).Value) = True Then
m = m + 1
Cells(sat1, i).Value = deg6(m)
End If
Next i
Next k
End Sub

 

[meslek5]

Sayfa1 de bu kodu bir dene

Sub deneme1()

son = 22
ilk = 3

ReDim deg1(son)
ReDim deg2(son)
ReDim deg3(son)
ReDim deg4(son)
ReDim deg5(son)
ReDim deg6(son)

For k = 4 To 23

sat1 = k
sat = 0
For j = ilk To son
If IsNumeric(Cells(sat1, j).Value) = True Then
sat = sat + 1
deg1(sat) = 0
deg2(sat) = 1
deg3(sat) = Cells(sat1, j).Value
deg4(sat) = 1
End If
Next j

For i = 1 To sat
atla:
say = Int((Rnd * sat) + 1)
If Val(deg1(say)) = 0 Then
deg1(say) = 1
deg5(i) = deg3(say)
Else
GoTo atla
End If
Next i

sat2 = ilk - 1

For r = 1 To sat
aranan1 = deg5(r)
If deg2(r) = 1 Then
For i = r To sat
If deg5(i) = aranan1 Then
deg2(i) = 0
deg6(sat2) = deg5(i)
sat2 = sat2 + 1
End If
Next i
End If
Next r

m = 0
For i = 1 To son
If IsNumeric(Cells(sat1, i).Value) = True Then
m = m + 1
Cells(sat1, i).Value = deg6(m)
End If
Next i
Next k
End Sub

Hocam bu tam istediğim gibi bir kod. İnanın çok mutlu oldum. Fakat neden kasıyor. Çünkü bu kodu belirli bir sonucu elde edinceye kadar döngüde çalıştıracağım. Bu döngü belki 5 dakika bile sürebilir bu yüzden kod hızlı çalışabilir mi?

 

[halit3]

Birde bunu dene

Sub deneme4()

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With

ilk_sut = 3 ' baslangıc sutunu
son_sut = 22 ' bitis sutunu
son_sat = 23 'son satır
ilk_satir = 4 'baslangıc satırı

ReDim deg1(son_sut)
ReDim deg2(son_sut)
ReDim deg3(son_sut)
ReDim deg4(son_sut)
ReDim deg5(son_sut)

For k = ilk_satir To son_sat

sat1 = k
sat = 0

For j = ilk_sut To son_sut
If Val(Cells(sat1, j).Value) > 0 Then
sat = sat + 1
deg1(sat) = 1
deg2(sat) = 1
deg3(sat) = Cells(sat1, j).Value
End If
Next j

If sat = 0 Then GoTo atla2

For i = 1 To sat
atla:
say = Int((Rnd * sat) + 1)
If Val(deg1(say)) = 1 Then
deg1(say) = 0
deg4(i) = deg3(say)
Else
GoTo atla
End If
Next i

sat2 = ilk_sut - 1

For r = 1 To sat
aranan1 = deg4(r)
If deg2(r) = 1 Then
For i = r To sat
If deg4(i) = aranan1 Then
deg2(i) = 0
deg5(sat2) = deg4(i)
sat2 = sat2 + 1
End If
Next i
End If
Next r

m = 0
For i = 1 To son_sut
If IsNumeric(Cells(sat1, i).Value) = True Then
m = m + 1
Cells(sat1, i).Value = deg5(m)
End If
Next i
atla2:
Next k


With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With

MsgBox "işlem tamam"
End Sub

 

[meslek5]

Birde bunu dene

Sub deneme4()

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With

ilk_sut = 3 ' baslangıc sutunu
son_sut = 22 ' bitis sutunu
son_sat = 23 'son satır
ilk_satir = 4 'baslangıc satırı

ReDim deg1(son_sut)
ReDim deg2(son_sut)
ReDim deg3(son_sut)
ReDim deg4(son_sut)
ReDim deg5(son_sut)

For k = ilk_satir To son_sat

sat1 = k
sat = 0

For j = ilk_sut To son_sut
If Val(Cells(sat1, j).Value) > 0 Then
sat = sat + 1
deg1(sat) = 1
deg2(sat) = 1
deg3(sat) = Cells(sat1, j).Value
End If
Next j

If sat = 0 Then GoTo atla2

For i = 1 To sat
atla:
say = Int((Rnd * sat) + 1)
If Val(deg1(say)) = 1 Then
deg1(say) = 0
deg4(i) = deg3(say)
Else
GoTo atla
End If
Next i

sat2 = ilk_sut - 1

For r = 1 To sat
aranan1 = deg4(r)
If deg2(r) = 1 Then
For i = r To sat
If deg4(i) = aranan1 Then
deg2(i) = 0
deg5(sat2) = deg4(i)
sat2 = sat2 + 1
End If
Next i
End If
Next r

m = 0
For i = 1 To son_sut
If IsNumeric(Cells(sat1, i).Value) = True Then
m = m + 1
Cells(sat1, i).Value = deg5(m)
End If
Next i
atla2:
Next k


With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With

MsgBox "işlem tamam"
End Sub

Tam istediğim gibi olmuş Allah sizden razı olsun hocam. Sizin gibi kod yazabilmeyi çok isterdim.

 

[halit3]

Tam istediğim gibi olmuş Allah sizden razı olsun hocam. Sizin gibi kod yazabilmeyi çok isterdim.

Teşekkürler iyi çalışmalar

 

[meslek5]

Teşekkürler iyi çalışmalar

Hocam şimdi tabloma uyarladım. Fakat bu sadece rakamlarda mı çalışıyor? bazen tablomun tamamı kişi isimlerinden oluşuyor bu durumda kodda nasıl bir değişiklik yapmam lazım?

 

[Muhammet Okumuş]

Kod metinleri aynı yerde bırakıyor.

 

[meslek5]

Peki hocam birşey yapamaz mıyız?

 

[halit3]

kod:

Sub deneme6()

With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With

ilk_sut = 3 ' baslangıc sutunu
son_sut = 22 ' bitis sutunu
son_sat = 23 'son satır
ilk_satir = 4 'baslangıc satırı

ReDim deg1(son_sut)
ReDim deg2(son_sut)
ReDim deg3(son_sut)
ReDim deg4(son_sut)
ReDim deg5(son_sut)

For k = ilk_satir To son_sat

sat1 = k
sat = 0

For j = ilk_sut To son_sut
If Cells(sat1, j).Value <> "+" Then
sat = sat + 1
deg1(sat) = 1
deg2(sat) = 1
deg3(sat) = Cells(sat1, j).Value
End If
Next j

If sat = 0 Then GoTo atla2

For i = 1 To sat
atla:
say = Int((Rnd * sat) + 1)
If Val(deg1(say)) = 1 Then
deg1(say) = 0
deg4(i) = deg3(say)
Else
GoTo atla
End If
Next i

sat2 = 0

For r = 1 To sat
aranan1 = deg4(r)
If deg2(r) = 1 Then
For i = r To sat
If deg4(i) = aranan1 Then
deg2(i) = 0
sat2 = sat2 + 1
deg5(sat2) = deg4(i)

End If
Next i
End If
Next r


m = 0
For i = ilk_sut To son_sut
If Cells(sat1, i).Value <> "+" Then
m = m + 1
Cells(sat1, i).Value = deg5(m)
End If
Next i
atla2:
Next k


With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
End With

MsgBox "işlem tamam"
End Sub