Mükerrer Olan Verinin Tespiti

[Baturfurkan]

Yedi çalışma sayfasındaki verilerin incelenip tekrar eden verilerin 8. çalışma sayfasında listelenmesini sağlayacak komut, formül yada makro arıyorum. Yardımlarınızı bekliyorum.

Detay: Ankara'nın yedi ilçesinin adını taşıyan yedi tane çalışma sayfası var. Buralara 6 haneli sicillerle görevlendirme yazıyorum. Aynı kişinin birden fazla göreve yazılmaması için 8. çalışma sayfamda mükerrer eden kişilerin listeleneceği bir formül arıyorum. Eskiden teker teker sicilleri 8. çalışma sayfasında alt alta yapıştırır koşullu biçimlendirme yapar sonra yazılı olduğu çalışma sayfasını bulmaya ve tek göreve düşürmeye uğraşırdım bu da çok vaktimi alıyor ve hata payı yüksek.

Şimdiden ilginiz ve yardımlarınız için teşekkür ederim. :dua2:

 

[askm]

2 şekilde yapabilirsiniz.
1. Sayfa sayfa verileri tek tek önce kendi sayfasında sonra diğer sayfalarda sayarsınız. 1 den fazla olanları listeleriniz.
2. 7 sayfayı 8. Sayfada toplar, olasan yeni listede tek tek sayarsınız. 1 den fazla olanları kalır.

 

[BedriA]

Bir kişi sadece bir görev mi alacak?
İlçe sayfalarında görevli kişilerin sicilleri yazıyor mu?

İkisine de cevap evet ise, Sicil numaraları bir sütuna toplanıp sırayla 7 sayfada taranır, eğer sadece 1 yerde rastlanmışsa yanına 1 yazılır, sıkıntı yok demek, birden fazla ise kaç kez olduğu yazılır ve gerekirse renklendirilir.

Her sayfada aşağıdaki fonksiyonu kullanıp toplamlarını 8. sayfasına yazdırmak mümkün.
Teorik olarak böyle.

EĞERSAY("Sicil_NO"; bulunduğu aralık)

 

[Baturfurkan]

Teşekkür ederim ama hala sorunuma bi çözüm getirebilmis değilim.

 

[askm]

Sub askm()
Dim s1, s2 As Worksheet
Dim SonSat, SonSat1 As Long
Set s1 = Sheets("KARŞILAŞTIRMA")
a = 2
Application.ScreenUpdating = False
For Syf = 1 To Sheets.Count
Set s2 = Sheets(Syf)
SonSat1 = s1.Range("A" & Rows.Count).End(xlUp).Row + 1
If s2.Name <> "KARŞILAŞTIRMA" Then
    SonSat = s2.Range("A" & Rows.Count).End(xlUp).Row
    s2.Range("B3:F" & SonSat).Copy
    s1.Select
    s1.Cells(SonSat1, 1).Select
    ActiveSheet.Paste
End If
Next Syf

For t = 2 To SonSat1
    Say = WorksheetFunction.CountIf(s1.Range("A2:A" & SonSat1), s1.Cells(t, 1))
    If Say > 1 Then
        For Z = 2 To SonSat1
           If s1.Cells(t, 1) = s1.Cells(Z, 1) Then
                İl = İl & " / " & s1.Cells(Z, 5)
            End If
        Next Z
        s1.Cells(t, 6) = Mid(İl, 2, Len(İl))
    End If
İl = Empty
Next t
End Sub

 

[Korhan Ayhan]

Mükerrer kayıt tespitini sayfaların "B" sütununa veri girişi esnasında yapabilirsiniz.

Aşağıdaki kodu "BuÇalışmaKitabı" bölümüne uygulayınız.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim Sayfa As Worksheet, Say As Integer
    
    If Intersect(Target, Range("B3:B" & Rows.Count)) Is Nothing Then Exit Sub
    
    For Each Sayfa In ThisWorkbook.Worksheets
        Say = Say + WorksheetFunction.CountIf(Sayfa.Range("B:B"), Target)
    Next
    If Say > 1 Then
        MsgBox Target & " numaralı sicilde mükerrer giriş tespit edildi!" & Chr(10) & "Girişiniz iptal edilmiştir.", vbCritical
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
End Sub

 

[Baturfurkan]

Teşekkür ederim deneyip ivedi bir şekilde dönüş yapacağım