Tekrarlanan verilerin hangi hücrelerde olduğunun bilgisinin msgboxta görüntelemek

[u.L.a.s]

Merhabalar

Aşağıdaki kod düzeneğinde H sütununda herhangi bir hücreye yine h sütununda başka bir hücrede varolan bir değeri yazmışsam bana msgbox ile uyarı veriyor ve bu yazdığım değeri ve diğer benzer değeri kırmızı renge çeviriyor.

sadece ufak bir işlem istiyorum bu kod üstünde msgbox üstünde uyarı verdiğinde bu girdiğim değer hangi hücrelerde mevcut bunuda göstersin istiyorum. bilgi ve yardımlarınızı rica ederim

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Local Error GoTo cikis
If Intersect(Target, Range("H:H")) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Range("H:H"), Target) > 1 Then
MsgBox "Benzer Veri Girişi Yapıldı. Kontrol Ederek Düzeltiniz", vbCritical, "Uyarı"
End If
If Target.Row = 1 Then Exit Sub
  
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
  
    Dim myDataRng As Range
    Dim cell As Range
  

    Set myDataRng = Range("H2:H" & Cells(Rows.Count, "H").End(xlUp).Row)
  
    For Each cell In myDataRng
        cell.Offset(0, 0).Font.Color = vbBlack
  
    
        If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & ")") > 1 Then
            cell.Offset(0, 0).Font.Color = vbRed
        End If
    Next cell
  
    Set myDataRng = Nothing
ErrHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[ÖmerBey]

Merhaba,
Kodunuzda yer alan aşağıdaki bölüme kırmızı kısmı ilave ediniz.

        If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & ")") > 1 Then
            cell.Offset(0, 0).Font.Color = vbRed
            adres = adres & vbLf & cell.Address
        End If

kodun sonuna da şu şatırı ilave ederek adresi görüntüleyebilirsiniz.
If adres <> "" Then MsgBox adres
adres değişkenini string olarak tanımlamayı unutmayınız.

 

[u.L.a.s]

Aşağıdaki gibi gerekli yerlerde düzeltmeleri yaptım çok güzel oldu emeğine bilgine sağlık. Çok ufak bir sorum daha olacak bu kısmı yapamadım çünkü.

Bu kodla aynı sheet üstüne benzer veri girişi yapılmışsa bu uyarı verdiriyorum. fakat başka bir sheet daha var yine bu sheette aynı H sütununda benzer bir veri varsa çıkan msgbox uyarısında o ilgili sheet adının ve ilgili hücre ismini de yazdırabilir miyiz bilgilerinizi rica ederim

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Local Error GoTo cikis
If Intersect(Target, Range("H:H")) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Range("H:H"), Target) > 1 Then
End If
If Target.Row = 1 Then Exit Sub

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    Dim myDataRng As Range
    Dim cell As Range
    Dim adres As String

    Set myDataRng = Range("H2:H" & Cells(Rows.Count, "H").End(xlUp).Row)

    For Each cell In myDataRng
        cell.Offset(0, 0).Font.Color = vbBlack


        If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & ")") > 1 Then
            cell.Offset(0, 0).Font.Color = vbRed
            adres = adres & vbLf & cell.Address & " Numaralı hücre"
        End If
    Next cell

    Set myDataRng = Nothing
ErrHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
If adres <> "" Then MsgBox "Aşağıda belirtilen hücrelerde benzer veri girişleri yapılmıştır. Düzeltiniz.!" & adres, vbCritical, "Benzer Veri Girişi Uyarısı"
End Sub

 

[ÖmerBey]

Tekrar merhaba,
Kodunuzu aşağıdaki şekilde düzenledim, deneyiniz...

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("H:H")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
If Target.Row = 1 Or Target.Value = "" Then Exit Sub

Dim sayfalar As Object, s As Worksheet
Dim hcr As Range
Dim adres As String
Dim say As Byte

Set sayfalar = Sheets(Array("Sayfa1", "Sayfa2")) 'Sayfa isimleri buraya yazılacak

For Each s In sayfalar
    say = say + WorksheetFunction.CountIf(s.Range("H:H"), Target)
    s.Range("H2:H" & Cells(Rows.Count, "H").End(xlUp).Row).Font.Color = vbBlack
Next

If say = 1 Then Exit Sub

Application.ScreenUpdating = False
For Each s In sayfalar
    For Each hcr In s.Range("H2:H" & s.Cells(Rows.Count, "H").End(xlUp).Row)
        If hcr.Value = Target.Value Then
            hcr.Font.Color = vbRed
            adres = adres & vbLf & s.Name & "!" & hcr.Address(0, 0) & " Numaralı hücre"
        End If
    Next hcr
Next s

Application.ScreenUpdating = True

If adres <> "" Then MsgBox "Aşağıda belirtilen hücrelerde benzer veri girişleri yapılmıştır. Düzeltiniz.!" & adres, vbCritical, "Benzer Veri Girişi Uyarısı"
End Sub