Karıştır ve sırala ..

[XExcel]

Mrb,

ek te izah ettim !

Emeği geçen ve yardımını esirgemeyen uzman Hocalarımıza teşekür ederim..

 

[Orion1]

Dosyanız ektedir.

Sub karistir()
Dim hcr As Range, deg As Double
Randomize Timer
Application.ScreenUpdating = False
For Each hcr In Range("A1:J5000")
    If hcr.Interior.Color = vbRed Then hcr.Value = ""
Next
For Each hcr In Range("A1:J5000")
    If hcr.Interior.Color = vbRed Then
tekrar:
        deg = Int(Rnd() * 5000) + 1
        If WorksheetFunction.CountIf(Range("A" & hcr.Row & ":J" & hcr.Row) _
        , deg) > 0 Then GoTo tekrar
        hcr.Value = deg
    End If
Next
Application.ScreenUpdating = True
MsgBox "Karıştırma tamamlanmıştır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub
Sub sirala_karistir()
Dim hcr As Range, col As Collection, i As Integer, k As Byte
Set col = New Collection
Application.ScreenUpdating = False
Range("L1:U1000") = ""
For Each hcr In Range("A1:J5000")
    If hcr.Interior.Color = vbRed And hcr.Value <> "" Then
        col.Add hcr.Value
    End If
Next
For i = 1 To 1000
    For k = 12 To 21
tekrar:
        deg = col(Int(Rnd() * col.Count) + 1)
        If WorksheetFunction.CountIf(Range("L" & i & ":U" & i) _
        , deg) > 0 Then GoTo tekrar
            Cells(i, k).Value = deg
    Next
    Range("L" & i & ":U" & i).Sort Key1:=Range("L" & i), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, _
        DataOption1:=xlSortNormal
Next
Application.ScreenUpdating = True
MsgBox "Karıştırma ve Sıralama tamamlanmıştır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[XExcel]

Emeğinize sağlık Hocam ,

istediğim tam olarak bu değildi, ek dosyayı yeni açıklama ve bir kaç değişiklik yaparak yeniden upload ettim !

Tşk..

 

[Orion1]

Emeğinize sağlık Hocam ,

istediğim tam olarak bu değildi, ek dosyayı yeni açıklama ve bir kaç değişiklik yaparak yeniden upload ettim !

Tşk..

Yine eksik var.Kırmızı kutucuk sayısı toplam kaç adet?

 

[XExcel]

Hocam bir örnek daha ekliyorum sanırım bunu indirdiğinizde konu daha iyi anlaşılacak ..

 

[Orion1]

Hocam bir örnek daha ekliyorum sanırım bunu indirdiğinizde konu daha iyi anlaşılacak ..

Yine ben soruma cevap alamadım.
Şimdi sağ tarafı unutun.
Şu an sol tarafı için uğraşıyoruz.
Tamam kırmızı kutucukların yeri değişecek.Onu anladım.Ama toplam kaç tane kırmızı kutucuk olacak.Bu soruma yanıt istiyorum.
Yoksa olmaz.Ben saydırdım 10393 tane kırmızı kutucuk var.O kadar olsunmu.Doğrumudur.Bu 10393 kere döngüye girecem ve belirtilen aralıkatak daha önceden koleksiyona aldığım adresleri rastgele çekicem kod ile çıkan adrese kırmızı rengi uygulayacam.Onun içindöngüye girebilmem için kırmızı kutucuk sayısını bilmem lazım.Üfürükle olsa hiç uğraşmayacam ama lazım işte bu kırmızı kutucuk sayısı.

 

[Orion1]

Dosyanın sol tarafı bölümünü yaptım.Ona bir bakın.Olduysa 2nci bölüme geçelim.
Bu durmda ikinci bölümde ilk 3 satırı siz elle düzenleyin ve açıklama yapın.Bende ona göre yapyım 2nci bölümü.