Hücre içinde bir den fazla tekrarlanan kelimeleri çıkartmak

yasin85

Altın Üye
Katılım
29 Haziran 2011
Mesajlar
256
Excel Vers. ve Dili
2019, Türkçe
Herkese Merhaba Kolay Gelsin,

Bir hücre içerisinde aynı kelimeden birden fazla varsa tekrarlananları alt örnekteki gibi tek hale nasıl getire biliriz.
Not: Sadece Metin içerikli işlemler için gerekli, Sayısal değerler olduğu gibi kalmasını istiyoruz.
Bu konuda yardımcı ola bilirmisiniz.

219433
 

kulomer46

Altın Üye
Katılım
23 Mart 2007
Mesajlar
1,512
Excel Vers. ve Dili
Microsoft Office LTSC Professional Plus 2021 - Türkçe
Merhaba

İsterseniz makrolu çözüm yazabilirim.
Sadece fonksiyonlu çözüm istiyorsanız şu an aklıma bir şey gelmiyor.

Selamlar...
 
Katılım
14 Kasım 2017
Mesajlar
618
Excel Vers. ve Dili
2010 Türkçe
Merhaba,
Gönüllü olarak, işinden, özel zamanından vakit ayırıp size yardımcı olacak kişileri uğraştırmamak adına, örnek dosya eklemeyi alışkanlık hâline getirelim. Sonrasında herkes elinden geldiğince yardımcı olacaklardır.

Saygılar
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
Örnek dosya yok, hücre içerisinde alt+enter kullanıldıysa hatalı sonuç verecektir.
Kod:
Sub TEST()
    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        bl = Split(Cells(i, 1))
        For ii = LBound(bl) To UBound(bl) - 1
            al = bl(ii)
            If Not IsNumeric(al) Then
                For iii = ii + 1 To UBound(bl)
                    If al = bl(iii) Then bl(iii) = ""
                Next iii
            End If
        Next ii
        Cells(i, 2) = WorksheetFunction.Trim(Join(bl))
    Next i
End Sub
 

Korhan Ayhan

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

C++:
Option Explicit

Sub Metin_Icindeki_Tekrar_Edenleri_Kaldir()
    Dim Dizi As Object, Veri As Variant, Son As Long, X As Long, Say As Long
    Dim Metin As Variant, Y As Integer, Ek As Integer, Sonuc As String, Zaman As Double
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son = 1 Then Son = 2
    
    Veri = Range("A1:A" & Son).Value
    
    ReDim Liste(1 To UBound(Veri), 1 To 1)
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            Metin = Split(Veri(X, 1), " ")
            For Y = LBound(Metin) To UBound(Metin)
                If Not IsNumeric(Metin(Y)) Then
                    If Not Dizi.Exists(Metin(Y)) Then Dizi.Add Metin(Y), Nothing
                Else
                    Ek = Ek + 1
                    Dizi.Add Metin(Y) & "|" & Ek, Nothing
                End If
            Next
            
            Sonuc = Join(Dizi.Keys, " ")
            
            Dizi.RemoveAll
            
            For Y = Ek To 1 Step -1
                Sonuc = Replace(Sonuc, "|" & Y, "")
            Next
        
            Ek = 0
            Say = Say + 1
            Liste(Say, 1) = Sonuc
            
            Sonuc = ""
        End If
    Next

    If Say > 0 Then Range("B1").Resize(Say, 1) = Liste
    
    Set Dizi = Nothing
    
    MsgBox "Tekrar eden veriler temizlenmiştir." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 

yasin85

Altın Üye
Katılım
29 Haziran 2011
Mesajlar
256
Excel Vers. ve Dili
2019, Türkçe
Örnek dosya yok, hücre içerisinde alt+enter kullanıldıysa hatalı sonuç verecektir.
Kod:
Sub TEST()
    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        bl = Split(Cells(i, 1))
        For ii = LBound(bl) To UBound(bl) - 1
            al = bl(ii)
            If Not IsNumeric(al) Then
                For iii = ii + 1 To UBound(bl)
                    If al = bl(iii) Then bl(iii) = ""
                Next iii
            End If
        Next ii
        Cells(i, 2) = WorksheetFunction.Trim(Join(bl))
    Next i
End Sub
sn. @veyselemre emeğiniz için teşekkür ederim çok işime yarayacak bir çalışma oldu.
dosyayıda ekliyorum ihtiyacı olan arkadaşlar kullana bilir..
iyi akşamlar
 

Ekli dosyalar

yasin85

Altın Üye
Katılım
29 Haziran 2011
Mesajlar
256
Excel Vers. ve Dili
2019, Türkçe
Altenatif;

C++:
Option Explicit

Sub Metin_Icindeki_Tekrar_Edenleri_Kaldir()
    Dim Dizi As Object, Veri As Variant, Son As Long, X As Long, Say As Long
    Dim Metin As Variant, Y As Integer, Ek As Integer, Sonuc As String, Zaman As Double
   
    Zaman = Timer
   
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son = 1 Then Son = 2
   
    Veri = Range("A1:A" & Son).Value
   
    ReDim Liste(1 To UBound(Veri), 1 To 1)
   
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            Metin = Split(Veri(X, 1), " ")
            For Y = LBound(Metin) To UBound(Metin)
                If Not IsNumeric(Metin(Y)) Then
                    If Not Dizi.Exists(Metin(Y)) Then Dizi.Add Metin(Y), Nothing
                Else
                    Ek = Ek + 1
                    Dizi.Add Metin(Y) & "|" & Ek, Nothing
                End If
            Next
           
            Sonuc = Join(Dizi.Keys, " ")
           
            Dizi.RemoveAll
           
            For Y = Ek To 1 Step -1
                Sonuc = Replace(Sonuc, "|" & Y, "")
            Next
       
            Ek = 0
            Say = Say + 1
            Liste(Say, 1) = Sonuc
           
            Sonuc = ""
        End If
    Next

    If Say > 0 Then Range("B1").Resize(Say, 1) = Liste
   
    Set Dizi = Nothing
   
    MsgBox "Tekrar eden veriler temizlenmiştir." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
sn. @Korhan Ayhan zaman ayırıp destek olduğunuz için sizlere çok teşekkür ederim sizin dosyanızıda ekledim denemek isteyen olursa diye bu işlem haftada toplama vurduğumuzda en az 5 - 6 saatimizi alıyordu böyle bir iş yükü üstümüzden kalktı şuanda.

iyi akşamlar, teşekkürler.
 

Ekli dosyalar

yasin85

Altın Üye
Katılım
29 Haziran 2011
Mesajlar
256
Excel Vers. ve Dili
2019, Türkçe
Merhaba

İsterseniz makrolu çözüm yazabilirim.
Sadece fonksiyonlu çözüm istiyorsanız şu an aklıma bir şey gelmiyor.

Selamlar...
sn. @kulomer46 ilginiz için teşekkür ederim.
Fonksiyonla ile ola bilecek bir çalışma olduğunu düşündüğüm için fonksiyon alanına ekledim, makro ile değerli vakitlerini harcamasınlar diye sağolsunlar desteklerini esirgemediler..
 

kulomer46

Altın Üye
Katılım
23 Mart 2007
Mesajlar
1,512
Excel Vers. ve Dili
Microsoft Office LTSC Professional Plus 2021 - Türkçe
sn. @kulomer46 ilginiz için teşekkür ederim.
Fonksiyonla ile ola bilecek bir çalışma olduğunu düşündüğüm için fonksiyon alanına ekledim, makro ile değerli vakitlerini harcamasınlar diye sağolsunlar desteklerini esirgemediler..
Selamlar...
 

yasin85

Altın Üye
Katılım
29 Haziran 2011
Mesajlar
256
Excel Vers. ve Dili
2019, Türkçe
sn @veyselemre & sn @Korhan Ayhan

Destek olduğunuz bu kod çalışmasında bugün tekrardan ihtiyacımız oldu kullandık 30000 kalemlik bir liste idi o listede çalışmadı fakat bir kaç kalem olduğunda çalışıyor. çalışma alanını mümkünse 30000 olarak revize ede bilirmisiniz.

Kolay gelsin
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,324
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Benim önerdiğim kodda bir sınırlama yoktur. Hata vermemesi gerekir.

Kod hangi satırda hata veriyor?
 

yasin85

Altın Üye
Katılım
29 Haziran 2011
Mesajlar
256
Excel Vers. ve Dili
2019, Türkçe
Sn. @Korhan Ayhan bey,

Hata vermiyor, sadece tekrar edenleri kaldırmıyor.
Listede kaldırılmayanlardan bir kısmı aşağıdaki gibidir.

OGUZ KAAN ADALI ADALI
MEHMET ADLIM ADLIM
MUTALIP ADMIR ADMIR
IRFAN AKCIL AKCIL
KAMIL AKHAN AKHAN
ERHAN AKIN AKIN
MURAT AKMAN AKMAN
VEDAT AKSOY AKSOY
AYHAN AKSU AKSU
SERDAR AKTAS AKTAS
YASIN AKTAS AKTAS
NECMETTIN AKYILDIRIM AKYILDIRIM
AKIF AL AL AKIF
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,324
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Örnek olarak verdiğiniz verileri boş bir dosyada 1 milyon satıra uyguladım. Hem @veyselemre beyin hem de benim önerdiğim kodu test ettim. Sıkıntı çıkarmadan çalıştı.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,324
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Tekrarların silinmediği hücrelerde fazladan Chr(160) kodlu boşluk görünüyor. Hücre içlerine F2 ile girerseniz görebilirsiniz.

Aşağıdaki kodu deneyiniz.

C++:
Option Explicit

Sub Metin_Icindeki_Tekrar_Edenleri_Kaldir()
    Dim Dizi As Object, Veri As Variant, Son As Long, X As Long, Say As Long
    Dim Metin As Variant, Y As Integer, Ek As Integer, Sonuc As String, Zaman As Double
    
    Zaman = Timer
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son = 1 Then Son = 2
    
    Veri = Range("A1:A" & Son).Value
    
    ReDim Liste(1 To UBound(Veri), 1 To 1)
    
    For X = LBound(Veri) To UBound(Veri)
        If Veri(X, 1) <> "" Then
            Metin = Split(WorksheetFunction.Trim(Replace(Veri(X, 1), Chr(160), "")), " ")
            For Y = LBound(Metin) To UBound(Metin)
                If Not IsNumeric(Metin(Y)) Then
                    If Not Dizi.Exists(Metin(Y)) Then Dizi.Add Metin(Y), Nothing
                Else
                    Ek = Ek + 1
                    Dizi.Add Metin(Y) & "|" & Ek, Nothing
                End If
            Next
            
            Sonuc = Join(Dizi.Keys, " ")
            
            Dizi.RemoveAll
            
            For Y = Ek To 1 Step -1
                Sonuc = Replace(Sonuc, "|" & Y, "")
            Next
        
            Ek = 0
            Say = Say + 1
            Liste(Say, 1) = Sonuc
            
            Sonuc = ""
        End If
    Next

    If Say > 0 Then Range("B1").Resize(Say, 1) = Liste
    
    Set Dizi = Nothing
    
    MsgBox "Tekrar eden veriler temizlenmiştir." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 

yasin85

Altın Üye
Katılım
29 Haziran 2011
Mesajlar
256
Excel Vers. ve Dili
2019, Türkçe
@Korhan Ayhan Bey,

çok teşekkür ederim şuan mükemmel bir şekilde çalışıyor.

İyi günler.
 
Katılım
3 Nisan 2009
Mesajlar
322
Excel Vers. ve Dili
2007
Korhan hocam , arkadaşta çalışmış ama ben çalıştıramadım.
Ekteki dosyaya bakarmısınız .
Bir isim ve bir telefon numarası (aynı satırda farklı bir telefon varsa iki farklı olan da) kalmasını istiyorum .
 

Ekli dosyalar

Son düzenleme:

Haluk

𐱅𐰇𐰼𐰚
Katılım
7 Temmuz 2004
Mesajlar
12,268
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Kişisel bilgileri içeren dosya paylaşmasanız iyi olacaktı ....

.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,324
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Kodun sizin verilerinizde çalışması için düzenlenmesi gerekir.
 
Üst