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

Katılım
2 Mayıs 2021
Mesajlar
56
Excel Vers. ve Dili
Excel 2016 - TR
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 tek tek kontrol etmek beni inanılmaz zorluyor. Eğer bu sorunumu çözebilirsek günlük işlerimi ve kontrollerimi çok daha raha yapabileceğim.

Aşağıda örnek liste var. Satır içi bazı kelimeler tekrar etmiş. aynı kelime 2 den fazla geçmişse ilgili satırı sarıya boyamak istiyorum. Şimdiden çok teşekkür ediyorum.

ABC Restoran Kayseri, Kayseri
S.O.S Dstv Installation and Repairs - Golf Park, Golf Park
Dabgha, Riyadh 13425
Falafel 1001 Oberhausen, Oberhausen

Kod çalıştıktan sonra aşağıdaki satırları sarıya boyaması gerekiyor.

ABC Restoran Kayseri, Kayseri
S.O.S Dstv Installation and Repairs - Golf Park, Golf Park

Dabgha, Riyadh 13425
Falafel 1001 Oberhausen, Oberhausen
 
Katılım
2 Mayıs 2021
Mesajlar
56
Excel Vers. ve Dili
Excel 2016 - TR
Hocam teşekkür ederim. Dosyayı indiremedim. Acaba başka bir yere yükleyebilir misiniz? Bazen satırlarda virgül olmayabiliyor. Dosyanızı bir denemek isterim.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,332
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Alternatif,

Hız olarak avantaj sağlayacaktır. (60.000 satır için test ettim yaklaşık 3,5 - 4 saniye civarında işlemi tamamlıyor.)

Verilerinizin A sütununda ve A1 hücresinden başladığı varsayılmıştır. Verileriniz bu konumda değilse kodu revize etmek gerekecektir.

C++:
Option Explicit

Sub Benzer_Kelime_Iceren_Hucreleri_Renklendir()
    Dim Dizi As Object, Veri As Variant, Zaman As Double
    Dim Son As Long, Kelime As Variant, Say As Long
    Dim X As Long, Y As Integer, Renklenen_Satir_Say As Long
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son < 2 Then Son = 2
    
    Veri = Range("A1:A" & Son).Value
    
    Range("A:A").Interior.ColorIndex = xlNone
    
    ReDim Liste(1 To 1)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Kelime = Split(Noktalama_Pasif(Veri(X, 1)), " ")
        For Y = LBound(Kelime) To UBound(Kelime)
            If Not Dizi.Exists(Kelime(Y)) Then
                Dizi.Add Kelime(Y), Nothing
            Else
                Say = Say + 1
                Renklenen_Satir_Say = Renklenen_Satir_Say + Say
                ReDim Preserve Liste(1 To Say)
                Liste(Say) = Cells(X, 1).Address(0, 0)
                If Len(CStr(Join(Liste, ","))) >= 250 And Len(CStr(Join(Liste, ","))) <= 255 Then
                    Range(CStr(Join(Liste, ","))).Interior.ColorIndex = 6
                    Erase Liste
                    ReDim Liste(1 To 1)
                    Say = 0
                End If
                Dizi.RemoveAll
                Exit For
            End If
        Next
    Next

    If Say > 0 Then Range(CStr(Join(Liste, ","))).Interior.ColorIndex = 6

    If Renklenen_Satir_Say > 0 Then
        MsgBox "Benzer kelimeleri içeren satırlar renklendirilmiştir." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Benzer kelime içeren hücre bulunamadı!" & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    End If
    
    Set Dizi = Nothing
End Sub

Function Noktalama_Pasif(ByVal Metin As String)
    Dim Noktalama As Variant
    
    Noktalama_Pasif = UCase(Replace(Replace((Metin), "ı", "I"), "i", "İ"))
    
    For Each Noktalama In Array("...", ".", "-", "—", "/", "\", "(", ")", "[", "]", "{", "}", """", "'", ",", ":", ";", "!", "?")
        Noktalama_Pasif = Replace(Noktalama_Pasif, Noktalama, "")
    Next
End Function
 
Katılım
2 Mayıs 2021
Mesajlar
56
Excel Vers. ve Dili
Excel 2016 - TR
Çok teşekkür ederim Korhan Hocam. Elinize sağlık.
 
Üst