aynı hücredeki mükerrer kayıtları sil

[tahsinanarat]

Ekli dosyada d ve e sütununda bulunan aynı kelime ve rakamların mükerrer olanlarını sil ancak birer tanesi kalsın. yani mükerrer olan kayıtlar hücre içinde teke düşürülecek.

Yardımlarınız için şimdiden teşekkürler.

 

[Ömer BARAN]

Merhaba.

Aşağıdaki kod'u kullanabilirsiniz.
.

[B]Sub AYNILARI_SIL()[/B]
Application.ScreenUpdating = False
For sut = 4 To 5
    Columns(sut).TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:=","
    For sat = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        sonsut = Cells(sat, Columns.Count).End(xlToLeft).Column
        If sonsut > 6 Then
            For sutt = 6 To sonsut
                Cells(sat, sutt) = Trim(Cells(sat, sutt))
            Next
                For suttt = sonsut To 7 Step -1
                    If WorksheetFunction.CountIf(Range(Cells(sat, 6), Cells(sat, suttt - 1)), _
                        Cells(sat, suttt)) > 0 Then
                        Cells(sat, suttt).Delete Shift:=xlToLeft
                        sutt = sutt - 1: sonsut = sonsut - 1
                    End If
                Next
                metin = Cells(sat, 6)
                If sonsut > 6 Then
                    For sutttt = 7 To sonsut
                        metin = metin & " ,  " & Cells(sat, sutttt)
                    Next
                End If
                Cells(sat, 6) = metin
        End If
    Next
    Range("F2:F" & Cells(Rows.Count, 1).End(xlUp).Row).Copy Cells(2, sut)
    Columns("F:IV").Delete Shift:=xlToLeft
Next
Range("D2:E" & Cells(Rows.Count, 1).End(xlUp).Row).NumberFormat = "@"
Columns("A:E").AutoFit
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
[B]End Sub[/B]

 

[tahsinanarat]

Sn. Ömer Baran hocam, çok mükemmel olmuş ellerinize sağlık. Çok Teşekkür ederim.

 

[Ömer BARAN]

Sn. Ömer Baran hocam, çok mükemmel olmuş ellerinize sağlık. Çok Teşekkür ederim.

Teşekkürler.

Aslında biraz daha sadeleştirmek mümkün sanırım ama,
ilk oluşturduğum şekilde bıraktım.

İşlem aşamaları şöyle: önce D sonra E sütunu için olmak üzere F sütunundan itibaren;
-- metni "," kriterine göre sütunlara ayır,
-- dağıtıldığı sütunlar için tek tek hücrelerde KIRP (Trim) işlevini kullanarak başta ve sondaki BOŞLUK karakterlerini sil,
-- Herbir satır için ayrı ayrı olmak üzere, en sağdaki hücreden başlayarak sola doğru,
F sütunu ile kendisinden bir önceki sütun aralığında bu değer varsa o hücreyi sola öteleyerek sil,
-- Kalan hücreleri araya tekrar virgüller ekleyerek F sütununda birleştir,
-- F sütununu kopyala D veya E sütunundan hangisiyle ilgili ise yapıştır,
-- F sütununu sil.
.

 

[Ömer BARAN]

Tekrar merhaba.

Kod'u yeniden gözden geçirince aşağıdaki daha kısa kod ortaya çıktı.
Gerçek belgenizde deneyiniz, önceki ve yeni kod sonuçlarını ve işlem hızını karşılaştırınız.
.

[B]Sub AYNILARI_SIL()[/B]
Application.ScreenUpdating = False
Columns("D:E").Replace What:=" ,  ", Replacement:="|", LookAt:=xlPart
For sut = 4 To 5
Columns(sut).TextToColumns [F1], Destination:=Range("F1"), DataType:=xlDelimited, Other:=True, OtherChar:="|"
    For sat = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        If Cells(sat, Columns.Count).End(xlToLeft).Column > 6 Then
            metin = Cells(sat, 6)
            For suttt = 7 To Cells(sat, Columns.Count).End(xlToLeft).Column
                If Len(Replace(metin, Cells(sat, suttt), "")) = Len(metin) Then _
                    metin = metin & " ,  " & Cells(sat, suttt)
            Next
            Cells(sat, 6) = metin
        End If
    Next
Range("F2:F" & Cells(Rows.Count, 1).End(xlUp).Row).Copy Cells(2, sut)
Columns("F:IV").Delete Shift:=xlToLeft
Next
Range("D2:E" & Cells(Rows.Count, 1).End(xlUp).Row).NumberFormat = "@"
Columns("A:E").AutoFit
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
[B]End Sub[/B]

 

[Asri]

Alternatif;

maksat beyin jimnastiği olsun

Sub tek_birak()
   Application.ScreenUpdating = False  
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   For i = 2 To sonsatir
     Cells(i, "F").Value = Cells(i, "D").Value & "/" & Cells(i, "E").Value
   Next i
    
   For i = sonsatir To 2 Step -1
     If WorksheetFunction.CountIf([F:F], Cells(i, "F").Value) > 1 Then Rows(i).Delete
   Next i
   Range("F:F").Clear   
   Application.ScreenUpdating = True
End Sub

 

[tolga1612]

Merhabalar,
Bu İşlemi Biraz Modifiye Ederek, Örneğin A Sütünundaki Veriler B Sütünunda Varsa A Sütünunda Olmayan Verileri C Sütünuna Çıkarabilecek Şekilde Şekilendirebilinirmi ? Şimdiden Teşekkür Eder Sevgilerimi Sunarım.

 

[Asri]

Merhabalar,
Bu İşlemi Biraz Modifiye Ederek, Örneğin A Sütünundaki Veriler B Sütünunda Varsa A Sütünunda Olmayan Verileri C Sütünuna Çıkarabilecek Şekilde Şekilendirebilinirmi ? Şimdiden Teşekkür Eder Sevgilerimi Sunarım.

Soruyu tam anlayamadım.
A sütununda olup B de olmayanları mı?
B de olup A sütununda olmayanları mı?

 

[tolga1612]

Soruyu tam anlayamadım.
A sütununda olup B de olmayanları mı?
B de olup A sütununda olmayanları mı?

Kusura Bakmayın Tekrar Okuyunca Bende Tam Nedemek İstediğimi Anlayamadım Düzeltiyorum.

Örneğin A Sütünunda 6000 Kayıt Var,
B Sütünunda İse 500 Kayıt.
Yapmak İstediğim Şey İse A Sütünunda Olup B Sütünunda Olmayanları Ayrı Bir Sütüna Aktarmak Acaba Mümkündür Bu Şekilde Bir Şey Yapılabilirmi Değerli Bilginiz Rica Ediyorum.

 

[Asri]

Kusura Bakmayın Tekrar Okuyunca Bende Tam Nedemek İstediğimi Anlayamadım Düzeltiyorum.

Örneğin A Sütünunda 6000 Kayıt Var,
B Sütünunda İse 500 Kayıt.
Yapmak İstediğim Şey İse A Sütünunda Olup B Sütünunda Olmayanları Ayrı Bir Sütüna Aktarmak Acaba Mümkündür Bu Şekilde Bir Şey Yapılabilirmi Değerli Bilginiz Rica Ediyorum.

Aşağıdaki şekilde deneyiniz.

Sub olmayani_ekle()
   Application.ScreenUpdating = False
   Range("C:C").Clear
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   satir = 1
   For i = 2 To sonsatir
     If WorksheetFunction.CountIf([B:B], Cells(i, "A").Value) = 0 Then
       satir = satir + 1
       Cells(satir, "C").Value = Cells(i, "A").Value
     End If
   Next i
   Application.ScreenUpdating = True
End Sub

 

[tolga1612]

Aşağıdaki şekilde deneyiniz.

Sub olmayani_ekle()
   Application.ScreenUpdating = False
   Range("C:C").Clear
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   satir = 1
   For i = 2 To sonsatir
     If WorksheetFunction.CountIf([B:B], Cells(i, "A").Value) = 0 Then
       satir = satir + 1
       Cells(satir, "C").Value = Cells(i, "A").Value
     End If
   Next i
   Application.ScreenUpdating = True
End Sub

Sonuç Başarılı Emeğinize Sağlık Teşekkür Ederim.