satırlardaki verilere kota koymak

[peleryn]

Herkese Merhabalar;

Ek'li dosyamda seans dağıtımı yaptığımız ana çizelgenin ufak bir modeli var.Uzman ve saat kriterlerine göre seans dağıtımı yapıyoruz.Ancak bu seansları dağıtırken aynı satırda bir başka sayfada belirtilmiş özelliklerine göre benzer özellikte ancak belli sayıda isim bir araya gelebilmeli..Makro ile dosyada ayrıntılarıyla açıkladığım kriterlere uygun bir çözüm öneren olursa çok sevinirim.


İlgilenecek olan herkese şimdiden teşekkür ederim.

 

[Orion1]

Dosyanız ektedir.
Fethiyede havalar nasıl gidiyor?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim k As Range, olcut As String, myarr(), j As Range
Dim say As Byte, s As Byte, t As Byte
If Intersect(Target, [B2:I11]) Is Nothing Then Exit Sub
On Error Resume Next
If Target.Value = "" Then Exit Sub
ReDim myarr(1 To 2, 1 To 4)
myarr(1, 1) = "İŞİTME"
myarr(2, 1) = 1
myarr(1, 2) = "BEDENSEL"
myarr(2, 2) = 4
myarr(1, 3) = "ZİHİNSEL"
myarr(2, 3) = 5
myarr(1, 4) = "OTİSTİK"
myarr(2, 4) = 1
Set k = Sheets("Sayfa2").Range("A2:A" & Sheets("Sayfa2").Cells(65536, "A") _
.End(xlUp).Row).Find(Target.Value, , xlValues, xlWhole)
If Not k Is Nothing Then olcut = k.Offset(0, 1).Value
For t = 2 To 9
    Set j = Sheets("Sayfa2").Range("A2:A" & Sheets("Sayfa2").Cells(65536, "A") _
    .End(xlUp).Row).Find(Cells(Target.Row, t).Value, , xlValues, xlWhole)
    If Not j Is Nothing Then
        If olcut = j.Offset(0, 1).Value Then
            say = say + 1
            For s = 1 To 4
                If myarr(1, s) = olcut Then
                    If say > CInt(myarr(2, s)) Then
                        MsgBox "[ " & myarr(1, s) & " ] " & myarr(2, s) & " kereden fazla yazılamaz!", vbCritical, "UYARI"
                        Application.EnableEvents = False
                        Target.Value = ""
                        Application.EnableEvents = True
                    End If
                End If
            Next s
        End If
    End If
Next t

End Sub

 

[peleryn]

Hocam ellerinize sağlık havalar çözümleriniz kadar güzel aşk için baharı bekleyenler varsa kışı boşa uzaklarda geçirmesinler

Çözümleriniz sayesinde bu güzel havaların tadını da çıkarmaya vakit bulabiliyorum açıkçası..Şimdi bir helallik istenir işte

Çok teşekkür ederim hocam ellerinize sağlık..

 

[Orion1]

Hocam ellerinize sağlık havalar çözümleriniz kadar güzel aşk için baharı bekleyenler varsa kışı boşa uzaklarda geçirmesinler

Çözümleriniz sayesinde bu güzel havaların tadını da çıkarmaya vakit bulabiliyorum açıkçası..Şimdi bir helallik istenir işte

Çok teşekkür ederim hocam ellerinize sağlık..

Rica ederim.
İyi çalışmalar.

 

[Orion1]

Rica ederim.
İyi çalışmalar.

alttaki satırın altına on error resume next kodunu eklerseniz iyi olur

If Intersect(Target, [B2:I11]) Is Nothing Then Exit Sub
[B][COLOR="Red"]on error resume next[/COLOR][/B]

 

[Orion1]

Dosyada değşiklik yaptım.
Şimdi ait olduğu grubu msgboxta belirtiyor.
Bu daha iyi oldu.
Önceki dosyayıyolladığımn yerden dosyayı indirebilirsiniz.

 

[peleryn]

Hocam ilk cevabınızda bu son yolladığınız halini nasıl yaparız diye soracaktım sizi bu konuyla daha fazla meşgul etmek istemedim bir fırsatını bulunca kendim halletmeye çalışırım diye düşünmüştüm ama şimdi siz onu da yapmışsınız sonra da "harikasınız" diyince kabul etmiyorsunuz "harika olan sizsiniz" diyorsunuz ne diyeyim ben şimdi

Tekrar çok teşekkür ediyorum hocam ayrıca bu konu vesilesiyle sizinle ilk kez havadan sudan da konuşmuş olduk onun için de ayrıca teşekkür ederim

 

[Orion1]

Hocam ilk cevabınızda bu son yolladığınız halini nasıl yaparız diye soracaktım sizi bu konuyla daha fazla meşgul etmek istemedim bir fırsatını bulunca kendim halletmeye çalışırım diye düşünmüştüm ama şimdi siz onu da yapmışsınız sonra da "harikasınız" diyince kabul etmiyorsunuz "harika olan sizsiniz" diyorsunuz ne diyeyim ben şimdi

Tekrar çok teşekkür ediyorum hocam ayrıca bu konu vesilesiyle sizinle ilk kez havadan sudan da konuşmuş olduk onun için de ayrıca teşekkür ederim

Rica ederim.
İyi çalışmalar.