Aralıktaki Yinelenen Değerleri Başka Aralıkta Boyamak

[klop01]

Arkadaşlar,
Worksheet_Change makrosu altında çalışacak biçimde aşağıdaki gibi bir makro nasıl oluşturulabilir?

A8:A67 aralığında yinelenen değer/ler varsa (boş hücreler hariç) E8:E67 aralığındaki ilgili hücreyi/hücreleri boyasın.
Örneğin A29 ve A36 yinelenen değer içeriyorsa E29 ve E36 hücreleri boyansın.

 

[ÖmerBey]

Merhaba,
Dosyanızdaki veriler formülle alındığı için worksheet_change kodları tetiklemeyecektir. Bu şekilde bir tetikleme için hücrelerdeki verinin kaynağına göre makro yazmak gerekecektir. Ya da worksheet_activate gibi alternatif olaylar denenebilir.
Tüm bunlarla birlikte kişisel kanaatim isteğinizin koşullu biçimle yapılarak çözülmesi yönünde olurdu.
E8:E67 aralığında koşullu biçimlendirme yapmak için ilgili alanda =VE($A8<>"";EĞERSAY($A$8:$A$67;$A8)>1) formülünü deneyebilirsiniz.
İyi çalışmalar...

 

[klop01]

ÖmerBey,
E8:E67 aralığında elle veri yazacağım. Bunlar A8:A67 aralığında varsa tetikleme olacak.
Koşullu biçimlendirme yapmaya müsait olmayan bir sayfada çalıştığım için makroyu denemek istedim.

 

[ÖmerBey]

İlk mesajınızla son mesajınızdan farklı şeyleri anladım. Netleştirmek adına soruyorum:
Siz verileri E8:E67 aralığına gireceksiniz.
Bu veriler A8:A67 aralığında bir tane bile varsa renklendirme yapılacak.
Renklendirme E sütununa yapılacak.
Doğru mudur?

 

[klop01]

ÖmerBey,
Doğrudur.
Renklendirme E sütununda yapılacak.

E8:E67 aralığına elle yazdığım veriler A8:A67 aralığında birden fazla geçiyorsa E sütunundaki ilgili hücre ya da hücreler renklensin.

 

[ÖmerBey]

Deneyiniz...

Private Sub Worksheet_Change(ByVal Target As Range)
Dim hcr As Range
If Not Intersect(Range("E8:E67"), Target) Is Nothing Then
    For Each hcr In Intersect(Range("E8:E67"), Target)
        hcr.Interior.Color = IIf(hcr <> "" And WorksheetFunction.CountIf(Me.Range("A8:A67"), hcr) > 1, vbRed, xlNone)
    Next
End If
End Sub

 

[klop01]

ÖmerBey,
Kod için teşekkür ederim.
Bir sorun var.
Eklediğim belgede konuyu örnekle açıklamaya çalıştım.
Acelesi yok, vaktiniz olursa dosyaya bakmanızı rica ederim.

 

[ÖmerBey]

Umarım anlamışımdır, dener misiniz?

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("E8:E67"), Target) Is Nothing Then renklendir
End Sub

Private Sub renklendir()
Dim alan As Range, hcr As Range
Set alan = Me.Range("A8:A67")
For Each hcr In alan
    hcr.Offset(0, 4).Interior.ColorIndex = IIf(hcr <> "" And hcr.Offset(0, 4) <> "" And WorksheetFunction.CountIf(alan, hcr) > 1, 6, xlNone)
Next
End Sub

 

[klop01]

ÖmerBey,
Kod hatasız çalışıyor.
Çok teşekkür ederim, sağ olun.