AYNI HÜCREYE AYNI VERİ GİRİLİNCE UYARMASI

[voleclub]

Rami bey dediğiniz gibi değiştirdim ama yine  hata veriyor.

[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

[Rami]

Aşağıdaki örnekteki gibi olmalı:

[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

[voleclub]

Rami Bey çok teşekkür ederim.Küçük bir şey daha isteyeceğim. c5:k10 arasına aynı 3 veri girince birini siliyorya biz onu silmesekte renk değiştirse olurmu?

[Rami]

O zaman:
"ThisWorkbook" altındaki kodları:

Kod: [Seç]

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
Dim tpl As Integer, syf As String
On Error Resume Next
If Target.Value = "" Then Exit Sub
If Intersect(Target, [C5:K40]) Is Nothing Then Exit Sub
Application.EnableEvents = False
syf = UCase(Replace(Replace(ActiveSheet.Name, "ı", "I"), "i", "İ"))
If Left(syf, 5) <> "TABLO" Then Exit Sub
For Each sh In Worksheets
    If Left(syf, 5) = "TABLO" Then
        tpl = tpl + WorksheetFunction.CountIf(sh.Range(Target.Address), Target.Value)
    End If
Next
If tpl > 1 Then
    MsgBox Target.Value & " Başka sayfada kayıtlı." & vbLf & "ZİÇEV", vbOKOnly + vbInformation, "ZİÇEV"
    Target.Cells.Font.ColorIndex = 33
    Target.Select
Else
If Target.Cells.Font.ColorIndex <> 3 Then Target.Cells.Font.ColorIndex = xIAutomatic
End If
Application.EnableEvents = True
End Sub

"Tablo" sayfalarıdaki kodları da aşağıdaki gibi değiştirmek gerekli:

Kod: [Seç]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim adr2 As String
If Intersect(Target, [C5:K10,C11:K16,C17:K22,C23:K28,C29:K34,C35:K40]) Is Nothing Then Exit Sub
On Error Resume Next
adr2 = Target.Address
If Target.Row <= 10 Then
    adr = Range("C5:K10").Address
    ElseIf Target.Row <= 16 Then
    adr = Range("C11:K16").Address
    ElseIf Target.Row <= 22 Then
    adr = Range("C17:K22").Address
      ElseIf Target.Row <= 28 Then
    adr = Range("C23:K28").Address
    ElseIf Target.Row <= 34 Then
    adr = Range("C29:K34").Address
    ElseIf Target.Row <= 40 Then
    adr = Range("C35:K40").Address
End If
For x = 2 To 5
mc = WorksheetFunction.CountIf(Sheets("TABLO" & x).Range(adr), Target.Value) + mc
Next
If mc > 2 Then
    Target.Select
   If Target.Value <> "" Then
    MsgBox Target.Value & " BU HAFTA 2 DERS SAATLİK LİMİTİNİ DOLDURMUŞTUR" & vbLf & "LÜTFEN BAŞKA HAFTAYA YAZINIZ", vbOKOnly + vbInformation, "Dikkat"
   Target.Cells.Font.ColorIndex = 3
  End If
End If
If mc <= 2 Then Target.Cells.Font.ColorIndex = xlAutomatic
End Sub 
Ancak veri değiştirilip hücreden çıkıncaya kadar; yazı rengi kırmızı olacaktır.

[voleclub]

RAmi Bey ben mi yapamadım dediğinizi yazdım ama hata veriyor.

[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

[voleclub]

Tabloya yazılan kodlar çok güzel çalışıyor ancak "ThisWorkbook" altındaki kodlar çalışmıyor.

[Rami]

Siz yukarıdaki "Thisworkbook" altıntaki kodları
 

Kod: [Seç]

'.....
'......
If Target.Cells.Font.ColorIndex <> 3 Then
Target.Cells.Font.ColorIndex = xIAutomatic
End If
End If '...eksik......................
Application.EnableEvents = True
End Sub
şeklinde değiştirerek yazmışsınız "End ıf" noksan.

Ya önceki ki mesajımdaki kodu aynen yazın veya böyle değiştirin.

[voleclub]

Rami Bey elinize sağlık ,Tablo 1 de 3 tane AAA var .İkincisinden sonraki yani ücüncüsü kırmızı oluyor.  3 tane aynı veri varsa üçüde kırmızılaşabilirmi.
2. si ise 3 veriden birini silince kırmızı renkler geri siyah olabilir mi?

[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

[Rami]

Ancak veri değiştirilip hücreden çıkıncaya kadar; yazı rengi kırmızı olacaktır.

[voleclub]

Bu kodu iki tane aynı veri varken üçüncü aynı veriyide girince üçüde kırmızı olsun ve işlemi düzeltip 3 taneden her hangi birini sildikten sonra geri kalan 2'si siyah olsuna dönüştürebilirmiyiz.Teşekkürler.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim adr2 As String
If Intersect(Target, [C5:K10,C11:K16,C17:K22,C23:K28,C29:K34,C35:K40]) Is Nothing Then Exit Sub
On Error Resume Next
adr2 = Target.Address
If Target.Row <= 10 Then
adr = Range("C5:K10").Address
ElseIf Target.Row <= 16 Then
adr = Range("C11:K16").Address
ElseIf Target.Row <= 22 Then
adr = Range("C17:K22").Address
ElseIf Target.Row <= 28 Then
adr = Range("C23:K28").Address
ElseIf Target.Row <= 34 Then
adr = Range("C29:K34").Address
ElseIf Target.Row <= 40 Then
adr = Range("C35:K40").Address
End If
For x = 1 To 20
mc = WorksheetFunction.CountIf(Sheets("TABLO" & x).Range(adr), Target.Value) + mc
Next
If mc > 2 Then
Target.Select
If Target.Value <> "" Then
MsgBox Target.Value & " BU HAFTA 2 DERS SAATLİK LİMİTİNİ DOLDURMUŞTUR" & vbLf & "LÜTFEN BAŞKA HAFTAYA YAZINIZ", vbOKOnly + vbInformation, "Dikkat"
Target.Cells.Font.ColorIndex = 3
End If
End If
If mc <= 2 Then Target.Cells.Font.ColorIndex = xlAutomatic
End Sub

[voleclub]

Rami Bey,
"ThisWorkbook" altındaki kodları bir butona atasak olurmu?
Yani tüm tabloyu doldurduktan sonra o butona basınca tüm aynı saate gelen (çakışan) dersleri yeşile çevirse olurmu?