Tüm çalışma kitabında mükerrer kayıt işaretleme ve uyarı mesajı alma...

[Jeeday]

Excel üstatları kolay gelsin,

Bir çok örneği olmasına rağmen bana lazım olanı malesef bulamadım...

İstediğim şey şöyle...

Birden fazla sayfa içeren çalışma kitabında sadece B sütunlarında aranmak üzere mükerrer kayıtları işaretleyecek ve aynı zamanda "Girdiğiniz "Kitap" (herhangi bir kelime vb.) kelimesi "Sayfa2"de mevcuttur." gibi bir uyarı açılacak...

Böyle bir şey uygulanabilir mi?

 

[leumruk]

Merhaba,
Herhangi bir sayfanın b sütununda girdiğiniz veriyi tüm sayfaların b sütununda arar. Tekrar eden veri varsa size adreslerini belirtir ve ilgili hücreleri sarıya boyar.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [b:b]) Is Nothing Then Exit Sub
If Target = "" Then Exit Sub
For x = 1 To Sheets.Count
Set Aralik = Sheets(x).Range("b:b")
Aralik.Interior.ColorIndex = xlNone
Set Bul = Aralik.Find(Target, LookIn:=xlValues, lookat:=xlWhole)
    If Not Bul Is Nothing Then
    Adres = Bul.Address
        Do
        If ActiveSheet.Name & Target.Address <> Sheets(x).Name & Bul.Address Then
        msj = msj & Chr(10) & Sheets(x).Name & " " & Bul.Address
        Bul.Interior.ColorIndex = 6
        Say = Say + 1
        End If
        Set Bul = Aralik.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
Next
If Say > 0 Then
MsgBox "Girdiğiniz veri aşağıda belirtilen adreslerde bulunmaktadır:" & Chr(10) & msj _
& Chr(10) & Chr(10) & "NOT: Bulunan veriler sarıya boyanacaktır."
End If
Son:
End Sub

 

[Jeeday]

ooo harika olmuş teşekkürler ama ufak bir detay daha var... sizin yolladığınız örnek üzerinden gidersek eğer "necati" yazdık diyelim...
1. sarıya boyuyor bulduğu yerleri ve msj çıkıyor buraya kadar ok... yazdığımız necati'yide sarıya boyasın...
2. sildiğimiz zaman "necati" girdisini boyanan yerler eski haline dönsün... silince sarılar kalıyo sizin yolladığınızda...

teşekkürler

 

[leumruk]

Merhaba,
Sayfadaki kodu aşağıdakiyle değiştirin.
NOT: B sütunundaki herhangi bir hücreyi silmeniz tüm sarı renkleri temizleyecektir.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [b:b]) Is Nothing Then Exit Sub
For x = 1 To Sheets.Count
Set Aralik = Sheets(x).Range("b:b")
Aralik.Interior.ColorIndex = xlNone
If Target = "" Then GoTo Sil
Set Bul = Aralik.Find(Target, LookIn:=xlValues, lookat:=xlWhole)
    If Not Bul Is Nothing Then
    Adres = Bul.Address
        Do
        If ActiveSheet.Name & Target.Address <> Sheets(x).Name & Bul.Address Then
        msj = msj & Chr(10) & Sheets(x).Name & " " & Bul.Address
        Bul.Interior.ColorIndex = 6
        Say = Say + 1
        End If
        Set Bul = Aralik.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
Sil:
Next
If Say > 0 Then
Target.Interior.ColorIndex = 6
MsgBox "Girdiğiniz veri aşağıda belirtilen adreslerde bulunmaktadır:" & Chr(10) & msj _
& Chr(10) & Chr(10) & "NOT: Bulunan veriler sarıya boyanacaktır."
End If
Son:
End Sub

 

[Jeeday]

çok teşekkür ederim tam istediğim gibi oldu

 

[FİKRETALİ]

HERKESE MERHABA,Bana yardımcı olursanız sevinirim.Hesap ekstresindeki verileri isim isim ve ödeme tarih ve tutarları ile birlikte nasıl başka bir sütüna nasıl yazdırabilirim.tekrar eden aynı veriler var.bunlarıda ayrı ayrı yazdırmak istiyorum.Saygılarımla