Koşula Bağlı Tercih Değiştirme

[SERPICO1]

Merhaba arkadaşlar,

Elimde yüzlerce kursiyerin yapmış oldukları tercihleri içeren bir liste var. Her kursiyer 5 tercih yapabilir ama ancak açılan 3 kursa katılabilir. Kursun açılması için de en az 7 kişinin tercih etmesi lazım.

Benim isteğim kursiyerlerin tercih sıralamasını değiştirmeden onları açılan kurslara yerleştirmek. Mesela; bir kursiyerin 1. tercihi açılmış, 2. tercihi açılmamış, 3. tercihi açılmış... Açılmayan 2. tercihi yerine 4. tercihine yerleşsin. O da açılmamışsa 5. tercihine..

Örnek tablo ekte sunulmuştur, yardımlarınızı bekliyorum.

 

[Muhammet Okumuş]

Merhaba,

Sub Dağıt()
For i = 4 To 23
For j = 1 To 9
adet = WorksheetFunction.CountIf(Range("N" & i & ":V" & i), "x")
If adet = 3 Then GoTo 20
kac = WorksheetFunction.Match(j, Range("C" & i & ":K" & i), 0) + 2
If Cells(1, kac) = "H" Then GoTo 10
Cells(i, kac + 11) = "x"
10
Next j
20
Next i
End Sub

Kodu deneyiniz.

 

[SERPICO1]

Hocam ellerine sağlık, kod gayet güzel çalıştı.
Ancak 2 sorun oluştu:
1. Kodu çalıştırdıktan sonra tercihlerde değişiklik yaparsam tekrar kodu çalıştırdığımda değişikliği işlemiyor.
2. Eğer kursiyerin 4. ve 5. tercihleri de açılmamışsa kod hata veriyor. Bunun yerine sadece açılan kursları işaretlemesi sağlanabilir mi?

Tekrar teşekkürler.

 

[SERPICO1]

1. sorunu şu şekilde çözdüm:

Sub Dağıt()
Range("N4:V23").Select
Selection.ClearContents
For i = 4 To 23
For j = 1 To 9
adet = WorksheetFunction.CountIf(Range("N" & i & ":V" & i), "x")
If adet = 3 Then GoTo 20
kac = WorksheetFunction.Match(j, Range("C" & i & ":K" & i), 0) + 2
If Cells(1, kac) = "H" Then GoTo 10
Cells(i, kac + 11) = "x"
10
Next j
20
Next i
End Sub

 

[Muhammet Okumuş]

Bu kodu kullanınız.

Sub Dağıt()
Range("N4:V23").ClearContents
For i = 4 To 23
For j = 1 To 9
If WorksheetFunction.CountIf(Range("C" & i & ":K" & i), j) = 0 Then GoTo 20
adet = WorksheetFunction.CountIf(Range("N" & i & ":V" & i), "x")
If adet = 3 Then GoTo 20
kac = WorksheetFunction.Match(j, Range("C" & i & ":K" & i), 0) + 2
If Cells(1, kac) = "H" Then GoTo 10
Cells(i, kac + 11) = "x"
10
Next j
20
Next i
End Sub

 

[SERPICO1]

Çok teşekkürler, ellerinize sağlık, mükemmel oldu.
Çalışmalarınızda başarılar dilerim.

 

[Muhammet Okumuş]

Rica ederim. İyi çalışmalar.