• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

M

meslek5

Katılım
19 Eylül 2012
Mesajlar
322
Excel Vers. ve Dili
2010 türkçe
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
 
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ı?
 
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.
 
Muhammet Okumuş' Alıntı:
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.
Genişletmek için tıkla ...
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
 
6+6 olabilir mi? Aynı grubun icerisine + konulabilir mi?
 
Muhammet Okumuş' Alıntı:
6+6 olabilir mi? Aynı grubun icerisine + konulabilir mi?
Genişletmek için tıkla ...
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
 
Son düzenleme:
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.
 
Mümkündür, mutlaka çözülür ama uğraşmak gerekiyor.
 
Sayfa1 de bu kodu bir dene

Kod: 
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
 
halit3' Alıntı:
Sayfa1 de bu kodu bir dene

Kod: 
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
Genişletmek için tıkla ...
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?
 
Birde bunu dene
Kod: 
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
 
Son düzenleme:
halit3' Alıntı:
Birde bunu dene
Kod: 
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
Genişletmek için tıkla ...
Tam istediğim gibi olmuş Allah sizden razı olsun hocam. Sizin gibi kod yazabilmeyi çok isterdim.
 
kod:
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
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst