Mükerrer Değer Sayısı (belirsiz değere göre)

meslek5 · 10 Haziran 2020

Merhaba,
Bir sütunda benzer değerleri sayan bir formüle ihtiyacım var.

Örnek: A1:A10 arasındaki hücreler içerisinde;

A1= Ahmet YILDIZ_Duygu BAYRAK_Derya ÇEVİK_Ankara
A2= Mesut DEMİR_Ali DURAK_Mehmet TAŞ_İzmir
A3= Feriha ANIL_Buse YAPRAK_Samsun
A4= Meltem DORUK_Mutlu YILDIZ_Semiha VAROL_İstanbul
A5= Hatice BAYRAM_Derya ÇEVİK_Bursa
A6= İsmail CAN_Gönül UYAR_Kaan ÇAĞLAR_Eskişehir
A7= Ali DURAK_Hatay
A8= Mutlu YILDIZ_Metin ÜNAL_Mersin
A9= Vahdet İNANÇ_Balıkesir
A10= Musa TOKCAN_Semiha VAROL_Ordu

A11= formül yazılıp mükerrer kelimeler sayılacak

Örnekteki sütunda 4 adet mükerrer var. Böyle bir durumda nasıl bir formül yazılırsa aralarda bile olsa mükerrer kelimeleri sayabilir.

Korhan Ayhan · 10 Haziran 2020

Alttaki KTF ile saydırabilirsiniz.

Kullanım şekli ; =YİNELENENLERİ_SAY(A1:A10;"_")

Sondaki ayraç kısmı opsiyoneldir. Dilerseniz boş bırakabilirsiniz. Yani =YİNELENENLERİ_SAY(A1:A10) şeklinde kullanabilirsiniz.

Fonksiyon bu haliyle sondaki ŞEHİR isimlerinde de tekrar durumu varsa onları da sayar.

C++:

Option Explicit

Function YİNELENENLERİ_SAY(Alan As Range, Optional Ayraç As String = "_")
    Dim Veri As Range, Kelime As Variant, X As Long, Say As Long
  
    Application.Volatile True
  
    With CreateObject("Scripting.Dictionary")
        For Each Veri In Alan
            If Veri.Value <> "" Then
                Kelime = Split(Veri.Value, Ayraç)
                For X = LBound(Kelime) To UBound(Kelime) - 1
                    If Not .Exists(Kelime(X)) Then
                        .Add Kelime(X), Nothing
                    Else
                        Say = Say + 1
                    End If
                Next
            End If
        Next
    End With
    YİNELENENLERİ_SAY = Say
End Function

meslek5 · 10 Haziran 2020

Korhan Ayhan' Alıntı:
Alttaki KTF ile saydırabilirsiniz.

Kullanım şekli ; =YİNELENENLERİ_SAY(A1:A10;"_")

Sondaki ayraç kısmı opsiyoneldir. Dilerseniz boş bırakabilirsiniz. Yani =YİNELENENLERİ_SAY(A1:A10) şeklinde kullanabilirsiniz.

Fonksiyon bu haliyle sondaki ŞEHİR isimlerinde de tekrar durumu varsa onları da sayar.

C++:

Option Explicit Function YİNELENENLERİ_SAY(Alan As Range, Optional Ayraç As String = "_") Dim Veri As Range, Kelime As Variant, X As Long, Say As Long Application.Volatile True With CreateObject("Scripting.Dictionary") For Each Veri In Alan If Veri.Value <> "" Then Kelime = Split(Veri.Value, Ayraç) For X = LBound(Kelime) To UBound(Kelime) If Not .Exists(Kelime(X)) Then .Add Kelime(X), Nothing Else Say = Say + 1 End If Next End If Next End With YİNELENENLERİ_SAY = Say End Function

Hocam teşekkür ederim. Şehir hariç saydırabilir miyiz? Sondaki ayraçı başka türlü kullansak veya başka bir yolu varmı

Korhan Ayhan · 10 Haziran 2020

Üstteki mesajımı revize ettim. Tekrar deneyiniz.

meslek5 · 10 Haziran 2020

Korhan Ayhan' Alıntı:
Üstteki mesajımı revize ettim. Tekrar deneyiniz.

Allah sizden razı olsun. Birçok alanda kullanılacak bir kod yazmışsınız.

meslek5 · 13 Haziran 2020

Korhan Ayhan' Alıntı:
Üstteki mesajımı revize ettim. Tekrar deneyiniz.

Korhan hocam bu yazdığınız kodu şu şekilde kullanmak istersek nasıl bir düzenleme yapmamız gerekiyor.

A1:A10 arasında yukarıdaki gibi bir mükerrer kayıt olursa A11 hücresine saydırmanın dışında o mükerrer hücreleri kırmızı yapılabilir mi?

Korhan Ayhan · 13 Haziran 2020

Deneyiniz.

C++:

Option Explicit

Sub Mukerrerleri_Renklendir()
    Dim Son As Long, Veri As Variant, X As Long
    Dim Kelime As Variant, Y As Integer, Bul As Integer
    
    Range("A1:A" & Rows.Count).Font.ColorIndex = -4105

    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A1:A" & Son).Value
    
    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri) To UBound(Veri)
            If Veri(X, 1) <> "" Then
                Kelime = Split(Veri(X, 1), "_")
                For Y = LBound(Kelime) To UBound(Kelime) - 1
                    If Not .Exists(Kelime(Y)) Then
                        .Add Kelime(Y), 1
                    Else
                        .Item(Kelime(Y)) = .Item(Kelime(Y)) + 1
                    End If
                Next
            End If
        Next
    
        For X = LBound(Veri) To UBound(Veri)
            If Veri(X, 1) <> "" Then
                Kelime = Split(Veri(X, 1), "_")
                For Y = LBound(Kelime) To UBound(Kelime) - 1
                    If .Item(Kelime(Y)) > 1 Then
                        Bul = InStr(1, Cells(X, 1), Kelime(Y))
                        Cells(X, 1).Characters(Start:=Bul, Length:=Len(Kelime(Y))).Font.Color = 255
                    End If
                Next
            End If
        Next
    End With

    MsgBox "Yinelenen isimler renklendirilmiştir.", vbInformation
End Sub

meslek5 · 13 Haziran 2020

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Mukerrerleri_Renklendir()
    Dim Son As Long, Veri As Variant, X As Long
    Dim Kelime As Variant, Y As Integer, Bul As Integer
   
    Range("A1:A" & Rows.Count).Font.ColorIndex = -4105

    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A1:A" & Son).Value
   
    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri) To UBound(Veri)
            If Veri(X, 1) <> "" Then
                Kelime = Split(Veri(X, 1), "_")
                For Y = LBound(Kelime) To UBound(Kelime) - 1
                    If Not .Exists(Kelime(Y)) Then
                        .Add Kelime(Y), 1
                    Else
                        .Item(Kelime(Y)) = .Item(Kelime(Y)) + 1
                    End If
                Next
            End If
        Next
   
        For X = LBound(Veri) To UBound(Veri)
            If Veri(X, 1) <> "" Then
                Kelime = Split(Veri(X, 1), "_")
                For Y = LBound(Kelime) To UBound(Kelime) - 1
                    If .Item(Kelime(Y)) > 1 Then
                        Bul = InStr(1, Cells(X, 1), Kelime(Y))
                        Cells(X, 1).Characters(Start:=Bul, Length:=Len(Kelime(Y))).Font.Color = 255
                    End If
                Next
            End If
        Next
    End With

    MsgBox "Yinelenen isimler renklendirilmiştir.", vbInformation
End Sub

Korhan hocam çok teşekkür ederim hemen ilgilendiniz. Zannedersem eksik ifade kullandım özür dilerim. Renklendirilmesi gereken Kelimeler değil hücreler olacaktı.

Korhan Ayhan · 13 Haziran 2020

Deneyiniz.

C++:

Option Explicit

Sub Mukerrerleri_Renklendir()
    Dim Son As Long, Veri As Variant, X As Long
    Dim Kelime As Variant, Y As Integer, Bul As Integer
    
    Range("A1:A" & Rows.Count).Interior.ColorIndex = xlNone

    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A1:A" & Son).Value
    
    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri) To UBound(Veri)
            If Veri(X, 1) <> "" Then
                Kelime = Split(Veri(X, 1), "_")
                For Y = LBound(Kelime) To UBound(Kelime) - 1
                    If Not .Exists(Kelime(Y)) Then
                        .Add Kelime(Y), 1
                    Else
                        .Item(Kelime(Y)) = .Item(Kelime(Y)) + 1
                    End If
                Next
            End If
        Next
    
        For X = LBound(Veri) To UBound(Veri)
            If Veri(X, 1) <> "" Then
                Kelime = Split(Veri(X, 1), "_")
                For Y = LBound(Kelime) To UBound(Kelime) - 1
                    If .Item(Kelime(Y)) > 1 Then
                        Bul = InStr(1, Cells(X, 1), Kelime(Y))
                        Cells(X, 1).Interior.ColorIndex = 3
                    End If
                Next
            End If
        Next
    End With

    MsgBox "Yinelenen isimler renklendirilmiştir.", vbInformation
End Sub

meslek5 · 13 Haziran 2020

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Mukerrerleri_Renklendir()
    Dim Son As Long, Veri As Variant, X As Long
    Dim Kelime As Variant, Y As Integer, Bul As Integer
   
    Range("A1:A" & Rows.Count).Interior.ColorIndex = xlNone

    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A1:A" & Son).Value
   
    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri) To UBound(Veri)
            If Veri(X, 1) <> "" Then
                Kelime = Split(Veri(X, 1), "_")
                For Y = LBound(Kelime) To UBound(Kelime) - 1
                    If Not .Exists(Kelime(Y)) Then
                        .Add Kelime(Y), 1
                    Else
                        .Item(Kelime(Y)) = .Item(Kelime(Y)) + 1
                    End If
                Next
            End If
        Next
   
        For X = LBound(Veri) To UBound(Veri)
            If Veri(X, 1) <> "" Then
                Kelime = Split(Veri(X, 1), "_")
                For Y = LBound(Kelime) To UBound(Kelime) - 1
                    If .Item(Kelime(Y)) > 1 Then
                        Bul = InStr(1, Cells(X, 1), Kelime(Y))
                        Cells(X, 1).Interior.ColorIndex = 3
                    End If
                Next
            End If
        Next
    End With

    MsgBox "Yinelenen isimler renklendirilmiştir.", vbInformation
End Sub

Korhan Hocam çok makbule geçti Allah ne muradınız varsa versin. Tam da bu kodun üzerine yapılmak istenen son işlem için Size yarın bir örnek dosya göndersem ve yapılmak isteneni açık ve net bir şekilde tarif etsem bakabilir misiniz? Eğer ilgilenirseniz (ki bahse konu işlem sizin için çok basit bir şey) uzun süredir bitirmek istediğim işi sizin de yardımınızla sonlandırmış olacağım. Şimdiden çok çok teşekkür ederim.

Bu siteyi kuran ve sizler gibi destek sağlayan tüm uzmanlara, bizlere karşılıksız gösterdikleri bunca emekler için ne kadar teşekkür etsek azdır. Gecenin bu saatinde bizler için ayırdığınız zamana karşılık hakkınızı helal ediniz.

meslek5 · 13 Haziran 2020

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Mukerrerleri_Renklendir()
    Dim Son As Long, Veri As Variant, X As Long
    Dim Kelime As Variant, Y As Integer, Bul As Integer
    
    Range("A1:A" & Rows.Count).Interior.ColorIndex = xlNone

    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A1:A" & Son).Value
    
    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri) To UBound(Veri)
            If Veri(X, 1) <> "" Then
                Kelime = Split(Veri(X, 1), "_")
                For Y = LBound(Kelime) To UBound(Kelime) - 1
                    If Not .Exists(Kelime(Y)) Then
                        .Add Kelime(Y), 1
                    Else
                        .Item(Kelime(Y)) = .Item(Kelime(Y)) + 1
                    End If
                Next
            End If
        Next
    
        For X = LBound(Veri) To UBound(Veri)
            If Veri(X, 1) <> "" Then
                Kelime = Split(Veri(X, 1), "_")
                For Y = LBound(Kelime) To UBound(Kelime) - 1
                    If .Item(Kelime(Y)) > 1 Then
                        Bul = InStr(1, Cells(X, 1), Kelime(Y))
                        Cells(X, 1).Interior.ColorIndex = 3
                    End If
                Next
            End If
        Next
    End With

    MsgBox "Yinelenen isimler renklendirilmiştir.", vbInformation
End Sub

Korhan hocam bu kodu A sütununda sorunsuz çalıştırıyorum. Ama "U22:CL71" aralığında çalıştırmak için kodda değişiklik yapınca hata veriyor. Belirttiğim aralığı kodun hangi bölümüne yazmalıyım.

Korhan Ayhan · 13 Haziran 2020

Deneyiniz.

C++:

Option Explicit

Sub Mukerrerleri_Renklendir()
    Dim Veri As Variant, X As Long, Bul As Integer
    Dim Kelime As Variant, Y As Integer, Z As Integer
    
    Range("U22:CL71").Interior.ColorIndex = xlNone

    Veri = Range("U22:CL71").Value
    
    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            For Y = LBound(Veri, 2) To UBound(Veri, 2)
                If Veri(X, Y) <> "" Then
                    Kelime = Split(Veri(X, Y), "_")
                    For Z = LBound(Kelime) To UBound(Kelime) - 1
                        If Not .Exists(Kelime(Z)) Then
                            .Add Kelime(Z), 1
                        Else
                            .Item(Kelime(Z)) = .Item(Kelime(Z)) + 1
                        End If
                    Next
                End If
            Next
        Next
    
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            For Y = LBound(Veri, 2) To UBound(Veri, 2)
                If Veri(X, Y) <> "" Then
                    Kelime = Split(Veri(X, Y), "_")
                    For Z = LBound(Kelime) To UBound(Kelime) - 1
                        If .Item(Kelime(Z)) > 1 Then
                            Bul = InStr(1, Cells(X, Y), Kelime(Z))
                            Cells(X + 21, Y + 20).Interior.ColorIndex = 3
                        End If
                    Next
                End If
            Next
        Next
    End With

    MsgBox "Yinelenen isimler renklendirilmiştir.", vbInformation
End Sub

Mükerrer Değer Sayısı (belirsiz değere göre)

meslek5

Korhan Ayhan

Administrator

meslek5

Korhan Ayhan

Administrator

meslek5

meslek5

Korhan Ayhan

Administrator

meslek5

Korhan Ayhan

Administrator

meslek5

meslek5

Korhan Ayhan

Administrator