Kod düzenleme

[mahmutozdemir]

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim hcr As Range
If Intersect(Target, Range("c5:ı15")) Is Nothing Then Exit Sub
If Left(ActiveSheet.Name, 5) = "TABLO" And _
WorksheetFunction.CountIf(Range("c5:ı15"), Target) > 2 _
Then
For Each hcr In Range("c5:ı15")
If hcr.Value = Target.Value Then
hcr.Interior.ColorIndex = 8
End If
Next

End If
End Sub
Yukardaki kodu,
tablo yazan sayfarın c5:ı15 arasına aynı veriyi 2 den fazla girince mavi renge boyuyor.
1-tablo1 de 2 tane iken tablo2 dede1 tane varsa (2+1:3 ) maviye boyamıyor.yani tablo yazan değişik sayfalarda da olsa aynı veriyi 2 den fazla yazınca maviye boyasın.
2-Bu kodla örneğin 3 tane aynı veriyi girince 3 de mavi oluyor. Ancak birini silince hata düzelmiş oluyor ama mavi renk ortadan kalkmıyor.Teşekkürler.

 

[hamitcan]

Biraz karışık anlatmışsınız. Bir dosya içinde, bir örnek ile açıklayın.

 

[mahmutozdemir]

örnek dosyayı ekledim.

 

[hamitcan]

Dosyanızda, 5 adet tablo var. Hepsi kontrol edilecek mi ?

 

[mahmutozdemir]

Tabloları bir bütün olarak düşünmemiz gerekiyor.
yani tablo1 tablo 2 tablo3 tablo4 tablo5in c5:ı15 hücreleri arasına girilen aynı veri2 den fazla olmamalı.Örneğin tablo3 de ali 2 tane varsa tablo yazan sayfaların herhangi birine bir daha ali yazarsak hepsi mavi olsun

 

[hamitcan]

Bu iki kodu, ThisWorkBook kısmına ekleyin.

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
For Each hcr3 In Sh.[c5:i15]
hcr3.Interior.Color = xlNone
Next
For Each hcr In Sh.[c5:i15]
If hcr = "" Then
GoTo 10
Else
S1 = WorksheetFunction.CountIf(Sheets("TABLO (1)").Range("c5:i15"), hcr.Value)
S2 = WorksheetFunction.CountIf(Sheets("TABLO (2)").Range("c5:i15"), hcr.Value)
S3 = WorksheetFunction.CountIf(Sheets("TABLO (3)").Range("c5:i15"), hcr.Value)
S4 = WorksheetFunction.CountIf(Sheets("TABLO (4)").Range("c5:i15"), hcr.Value)
S5 = WorksheetFunction.CountIf(Sheets("TABLO (5)").Range("c5:i15"), hcr.Value)
If S1 + S2 + S3 + S4 + S5 > 2 Then
    For Each hcr2 In Sh.[c5:i15]
        If hcr2.Value = hcr.Value Then hcr2.Interior.Color = vbBlue
    Next
End If
End If
10
Next
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
For Each hcr3 In Sh.[c5:i15]
hcr3.Interior.Color = xlNone
Next
For Each hcr In Sh.[c5:i15]
If hcr = "" Then
GoTo 10
Else
S1 = WorksheetFunction.CountIf(Sheets("TABLO (1)").Range("c5:i15"), hcr.Value)
S2 = WorksheetFunction.CountIf(Sheets("TABLO (2)").Range("c5:i15"), hcr.Value)
S3 = WorksheetFunction.CountIf(Sheets("TABLO (3)").Range("c5:i15"), hcr.Value)
S4 = WorksheetFunction.CountIf(Sheets("TABLO (4)").Range("c5:i15"), hcr.Value)
S5 = WorksheetFunction.CountIf(Sheets("TABLO (5)").Range("c5:i15"), hcr.Value)
If S1 + S2 + S3 + S4 + S5 > 2 Then
    For Each hcr2 In Sh.[c5:i15]
        If hcr2.Value = hcr.Value Then hcr2.Interior.Color = vbBlue
    Next
End If
End If
10
Next
End Sub

 

[mahmutozdemir]

Teşekkür ederim. Ellerinize sağlık.

 

[mahmutozdemir]

Hamit Bey,
Bunu kodu c5:i15 için ,c16:i26 için ve c27:i27 için ayrı ayrı yapacağım. Bu üçünü birleştirip tek kod altında nası yazabilirim.

 

[hamitcan]

Tablo aralğını, c5:i27 şeklinde değiştirin, olsun bitsin. Maceraya gerek yok diye düşünüyorum.

 

[mahmutozdemir]

Ben onu haftalık olarak düşünüyorum.3 hafta olacak şekilde olması gerekiyor.Haftada 2 den fazla aynı verilemez.Ozaman 3 haftada 2 den fazla girilemez olur.
Şu kısımları For Each hcr2 In Sh.[c5:i15]
Sh.[c16:i26]
Sh.[c27:i37]
olarak değiştirsek olurmu.

 

[hamitcan]

Üç ayrı kod yazılıp bu kodlar isteğe göre çağrılabilir.