-
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)
- Konbuyu başlatan meslek5
- Başlangıç tarihi
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.
Ofis2010 kullanıyorum windows10 belki o yüzdendir. Ama rakam tablosu çok hızlı çalışıyor
Tamam hocam dosyayı açıp kapatınca oldu. Çok teşekkür ederim.
- Katılım
- 18 Ocak 2008
- Mesajlar
- 12,878
- Excel Vers. ve Dili
- 2003 excell türkçe
ve
2007 excell türkçe
Kod da küçük iyileştirmeler yapıldı.
Kod:
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