Aynı Sütunda Yinelenen Değerlere Aynı Değer Atamaya Uyarı

[Feylosof]

Merhaba,


UserFormdan comboboxtaki veriyi aktarırken. benzer olan satıra benzer veriyi aktarırken uyarı vermesini istiyorum. Dosyada anlatmaya çalıştıım. Umarım anlatabildim.

 

[Muzaffer Ali]

Merhaba.
Sayfanın kod kısmına kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("H3:V40")) Is Nothing Then
        If WorksheetFunction.CountIf(Range("H3:V40"), Target) > 1 Then
            MsgBox "Aynı derse aynı sınıf veremezsiniz."
            Target = Empty
            Target.Select
        End If
        
    End If
End Sub

 

[Feylosof]

@Muzaffer Ali Hocam ilginiz için çok teşekkür ediyorum. Şöyle bir durum var. Eğer ben uygulamada yanlış yapmıyorsam. Aynı derse aynı sınıfı birden fazla vermemeli ancak farklı derse aynı dersi verebilmeli. 10 ders varsa bir sınıf 10 kez atanabilmeli. Eğer bu kısmı aşabilirsek çok güzel olacak.

 

[Ziynettin]

Alternatif,

Bu şekilde deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("H3:V40")) Is Nothing Then
        a = [D3:V40].Value
        Set dc = CreateObject("scripting.dictionary")
        For i = 1 To UBound(a)
            For j = 5 To UBound(a, 2)
                If a(i, j) <> "" Then
                    krt = a(i, j) & "|" & a(i, 1)
                    dc(krt) = dc(krt) + 1
                End If
            Next j
        Next i
        
    ara = Target.Text & "|" & Cells(Target.Row, 4).Text
    ders = Cells(Target.Row, 4).Text
    If dc(ara) > 1 Then
        MsgBox "Aynı ders mevcut." & vbLf & vbLf & _
        "Sayi: " & dc(ara), vbCritical
        Application.Undo
    End If
    End If
End Sub

 

[Feylosof]

@Ziynettin Bey, size çok teşekkür ederim. Bu şekilde istediğim gibi oldu. Sizden bir şey daha rica etsem fazla mı olur?
uyarı veren kaydın önceki kayıt yerini renklendirebilir miyiz acaba? ya da daha mükemmeli msgbox kısmında o veriye denk gelen dersin adını yazsa. Ne güzel olur

 

[Ziynettin]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim alan As Range
Set alan = [D3:V40]

If Not Intersect(Target, alan) Is Nothing Then
    a = alan.Value
    alan.Interior.Color = rgbYellow
    Set dc = CreateObject("scripting.dictionary")
    Set ds = CreateObject("scripting.dictionary")
    Set dz = CreateObject("scripting.dictionary")
    
    For i = 1 To UBound(a)
        For j = 5 To UBound(a, 2)
            If a(i, j) <> "" Then
                krt = a(i, j) & "|" & a(i, 1)
                dc(krt) = dc(krt) + 1
                ds(krt) = ds(krt) & i & ","
                dz(krt) = dz(krt) & j & ","
                
            End If
        Next j
    Next i
        
    ara = Target.Text & "|" & Cells(Target.Row, 4).Text

    If dc(ara) > 1 Then
        sat = Split(ds(ara), ",")
        sut = Split(dz(ara), ",")
        For i = 0 To UBound(sat) - 1
            alan.Cells(Val(sat(i)), 1).Interior.Color = rgbBlue
            alan.Cells(Val(sat(i)), Val(sut(i))).Interior.Color = RGB(175, 238, 238)
            adres = adres & alan.Cells(Val(sat(i)), Val(sut(i))).Address(0, 0) & vbLf
        Next i
        MsgBox "Aynı bulunan: " & dc(ara) & " Adet" & vbLf & vbLf & vbLf & _
        "SINIFLAR" & vbLf & "--------------" & vbLf & adres, vbCritical
        Target.Select
    End If
End If
End Sub

 

[Feylosof]

@Ziynettin Hocam size çok teşekkür ederim. Çok makbule geçti doğrusu. Sağlıcakla kalın.