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

[halit3]

20 nolu mesajdaki kodu yeniden güncelledim

 

[meslek5]

20 nolu mesajdaki kodu yeniden güncelledim

Tamam hocam kodu sayfada çalıştırdım istenilen sonucu veriyor. Sadece rakamsal tablodaki diğer kod gibi seri değil ve döngüde kilitlenip excel yanıt vermiyor hatası veriyor. Mesela diğer rakamsal tablodaki karışım için hazırladığınız kodu 5 dakika döngüde çalıştırdım hiç hata vermedi ve seri çalışmıştı. Olsun bu şekilde kullanırım. Çok çok zahmet verdim hakkınızı helal edin.

 

[halit3]

Göndermiş olduğunuz dosyada kodu ben çalıştırdım çok çabuk sonuçları aktardı.
Ben ofis2003 kullanıyorum işletim sistemide windows 8.1

 

[meslek5]

Göndermiş olduğunuz dosyada kodu ben çalıştırdım çok çabuk sonuçları aktardı.
Ben ofis2003 kullanıyorum işletim sistemide windows 8.1

Ofis2010 kullanıyorum windows10 belki o yüzdendir. Ama rakam tablosu çok hızlı çalışıyor

 

[halit3]

Kodu ofis 2016 da denedim işletim sistemi windows10
bir iki saniyede aktardı

 

[meslek5]

Kodu ofis 2016 da denedim işletim sistemi windows10
bir iki saniyede aktardı

Tamam hocam dosyayı açıp kapatınca oldu. Çok teşekkür ederim.

 

[halit3]

Kod da küçük iyileştirmeler yapıldı.

Sub deneme7()

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

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


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

For k = ilk_satir To son_sat

sat1 = k
sat2 = 0

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

If sat2 = 0 Then GoTo atla2

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

sat3 = 0

For r = 1 To sat2
aranan1 = deg4(r)
If deg2(r) = 1 Then
For i = r To sat2
If deg4(i) = aranan1 Then
deg2(i) = 0
sat3 = sat3 + 1
deg5(sat3) = 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