Aynı hücredeki tekrarlı kelimeleri boyama

[nanotech3485]

Arkadaşlar merhaba, elimde 1 yıldan fazla bir süredir kullandığım bir makro var. Ama çok ağır çalışıyor. A sütununda binlerce satır veri var ve makro her bir hücrede aynı kelime iki veya daha fazla geçiyorsa ilgili satırı sarı renge boyuyor.

Örneğin;

ABC Döner Kartal, Kartal, İstanbul
Ali Motor Defne, Hatay
Akyüz Deneme, DENEME
...

1. ve 3. satırda aynı kelimeden geçtiği için 1. ve 3. satırı sarı renge boyuyor.

Şu an kullandığım dosya ektedir. En az 10 binlerce satır veri ile uğraşıyorum. Eğer çok daha hızlısı yapılabilirse çok memnun olacağım. Ayrıca işlem devam ederken ProgressBar ile işlemin % kaçının yapıldığını da görebilirsem mükemmel olacaktır. Teşekkür ederim.

 

[Haluk]

Sub Test()
    Dim i As Integer, NoA As Integer, myArr() As String, iCount As Integer
    
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1:A" & NoA).Interior.ColorIndex = 0
    
    For i = 1 To NoA
        myStr = LCase(Replace(Replace(Range("A" & i), ",", ""), ".", ""))
        myArr = Split(myStr)
        sCount = 0
        
        For x = LBound(myArr) To UBound(myArr)
            iCount = UBound(Split(myStr, myArr(x))) + 1
            If iCount > 2 Then
                Range("A" & i).Interior.ColorIndex = 6
                Exit For
            End If
        Next
    Next
End Sub

.

 

[nanotech3485]

Sub Test()
    Dim i As Integer, NoA As Integer, myArr() As String, iCount As Integer
   
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1:A" & NoA).Interior.ColorIndex = 0
   
    For i = 1 To NoA
        myStr = LCase(Replace(Replace(Range("A" & i), ",", ""), ".", ""))
        myArr = Split(myStr)
        sCount = 0
       
        For x = LBound(myArr) To UBound(myArr)
            iCount = UBound(Split(myStr, myArr(x))) + 1
            If iCount > 2 Then
                Range("A" & i).Interior.ColorIndex = 6
                Exit For
            End If
        Next
    Next
End Sub

.

Hocam kodu ekledim bazı satırları sarıya boyadı ama boyadığı satırlarda tekrarlı kelimeler maalesef yok. Ama çok hızlı çalıştı. Ben test datasını içeren dosyayı ekledim. Bakma şansınız var mıdır?

 

[Haluk]

Sub Test()
    Dim i As Long, NoA As Long, myArr() As String, x As Integer, iCount As Long, xWord As Variant
    
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1:A" & NoA).Interior.ColorIndex = 0
    
    For i = 1 To NoA
        myStr = LCase(Replace(Replace(Range("A" & i), ",", ""), ".", ""))
        myArr = Split(myStr)
        
        For x = LBound(myArr) To UBound(myArr)
            iCount = 0
            For Each xWord In myArr
                If xWord = myArr(x) Then
                    iCount = iCount + 1
                    If iCount >= 2 Then
                        Range("A" & i).Interior.ColorIndex = 6
                        Exit For
                    End If
                End If
            Next
        Next
    Next
End Sub

.

 

[nanotech3485]

Sub Test()
    Dim i As Long, NoA As Long, myArr() As String, x As Integer, iCount As Long, xWord As Variant
   
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1:A" & NoA).Interior.ColorIndex = 0
   
    For i = 1 To NoA
        myStr = LCase(Replace(Replace(Range("A" & i), ",", ""), ".", ""))
        myArr = Split(myStr)
       
        For x = LBound(myArr) To UBound(myArr)
            iCount = 0
            For Each xWord In myArr
                If xWord = myArr(x) Then
                    iCount = iCount + 1
                    If iCount >= 2 Then
                        Range("A" & i).Interior.ColorIndex = 6
                        Exit For
                    End If
                End If
            Next
        Next
    Next
End Sub

.

Haluk Bey çok teşekkürler kod çalışıyor ve inanılmaz hızlı. 10 bin veriyi 2 saniye de analiz etti Bu kadarını da beklemiyordum açıkçası. Hocam testimi yaptım. Türkçe büyük karakterlerde tekrarlı kelimeleri bulamadı.

Örneğin;

ABC Döner Şanlıurfa, ŞANLIURFA
Deneme Firması pendik, PENDİK

Galiba küçük ı ile büyük I aynı satırda olunca bulamıyor. Ayrıca şanlıurfa şeklinde yazarsam buluyor.
Deneme Firması pendik, PENDİK ise bu şekilde sarıya boyamadı. İ den dolayı olsa gerek. Kontrol edebilmeniz mümkün müdür acaba? Teşekkürler

 

[Haluk]

Yarin bir ara bakarim...

.

 

[Haluk]

Aşağıdaki satırı;

        myStr = LCase(Replace(Replace(Range("A" & i), ",", ""), ".", ""))

bununla değiştirin;

        myStr = LCase(Replace(Replace(Replace(Replace(Range("A" & i), "ı", "I"), "İ", "i"), ",", ""), ".", ""))

.

 

[Korhan Ayhan]

Merhaba,

Benzer bir soruyu cevapladığımı hatırlıyordum. Aradım buldum. Yine siz sormuşsunuz.

Satır içi aynı kelimeden birden fazla geçmesi

Arkadaşlar merhaba; Elimde 1 sütun da binlerce satır firma adı bilgisi var. Bazı satırlarda firma adında birden fazla aynı kelime veya kelimeler geçebiliyor. Acaba aynı satırda bir kelimeden birden fazla geçen satırları farklı bir renk ile belirtebilir miyiz? Günlük bazı çalışmalarım var manuel...

www.excel.web.tr

 

[nanotech3485]

Aşağıdaki satırı;

        myStr = LCase(Replace(Replace(Range("A" & i), ",", ""), ".", ""))

bununla değiştirin;

        myStr = LCase(Replace(Replace(Replace(Replace(Range("A" & i), "ı", "I"), "İ", "i"), ",", ""), ".", ""))

.

Haluk Bey çok teşekkür ederim. Sorun düzeldi. Hocam son olarak bayağı bir veride denedim. Satırda iki adet & veya / gibi özel karakterler geçiyorsa o satırı da boyuyor. Bu tarz özel karakterleri devre dışı bırakmak için hangi kodu eklemeliyim.

 

[Korhan Ayhan]

Bakınız 8 nolu mesaj...

 

[nanotech3485]

Merhaba,

Benzer bir soruyu cevapladığımı hatırlıyordum. Aradım buldum. Yine siz sormuşsunuz.

Satır içi aynı kelimeden birden fazla geçmesi

Arkadaşlar merhaba; Elimde 1 sütun da binlerce satır firma adı bilgisi var. Bazı satırlarda firma adında birden fazla aynı kelime veya kelimeler geçebiliyor. Acaba aynı satırda bir kelimeden birden fazla geçen satırları farklı bir renk ile belirtebilir miyiz? Günlük bazı çalışmalarım var manuel...

www.excel.web.tr

Merhaba Korhan Bey, evet geçen sene böyle bir soru sordum ama sizin mesajınızı görmemiştim. Sizden önce yazan arkadaşın kodunu kullanıyordum yaklaşık 60k veriyi kontrol etmesi 10 saatten fazla sürüyordu. Sizin kodunuzu görmediğim için deneme imkanım olmadı. Çok teşekkür ederim.

 

[Haluk]

Hücrede 2 aynı tek karakter varsa, eşleştirme olmadığını Excel'e tarif etmek için, aşağıdaki satırı;

                If xWord = myArr(x) Then

bununla değiştirin;

                If xWord = myArr(x) And Len(xWord) > 1 Then

.

 

[CenTay]

Korhan abinin verdiği linkte verdiği çözüme aynı anda teşekkür etmişsiniz, cevabı görmemiş olmanız olanaklı değil, sanırım gözden kaçtı.

 

[nanotech3485]

Hücrede 2 aynı tek karakter varsa, eşleştirme olmadığını Excel'e tarif etmek için, aşağıdaki satırı;

                If xWord = myArr(x) Then

bununla değiştirin;

                If xWord = myArr(x) And Len(xWord) > 1 Then

.

Hocam çok teşekkürler. Elinize sağlık deneyip haber vereceğim.