• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Mükerrer satırları teke düşürme.

F

FaLC10

Katılım
19 Mart 2012
Mesajlar
19
Excel Vers. ve Dili
2016
Sıkıntım başlıkta da yazdığı ve örnekte de gözüktüğü gibidir.
Bir satır da bulunan tüm stun değerleri eşitse eğer tüm satırı komple silmesini uygulayacak macro arıyorum. Mükerrer kayıtları teke düşürme ile ilgili çok bilgi buldum fakat hem tüm satırın değerlerini kontrol edecek hemde tüm satırı silebilecek birşey bulamadım. Mümkünse de bu işlemi tüm sayfalar için yapması çok iyi olur. İlginiz için şimdiden teşekkürler

Not: Excel 2016

ornek: http://s8.dosya.tc/server5/lx4vzj/ornek.xlsx.html
 
Merhaba.

Öncelikle profilinizdeki Ms.Excel versiyon bilgisini güncellemenizi hatırlatayım.

Sorunuzda "teke düşürme" demişsiniz ama, örnek belgede mükerrerlerin tümünün silinmesini istemişsiniz.
Aşağıdaki şekilde işlem yaptığınızda mükerrerler teke düşürülmez, tümü silinir.

-- Sayfanın alt tarafında açıklama yapmak için kullandığınız birleştirilmiş hücrelerdeki birleştirmeyi kaldırın ve içeriğini silin,
-- Alt taraftan Sayfa1'in adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
-- Açılan VBA ekranında sağdaki boş alana aşağıdaki kod'u yapıştırın,
-- Kod'u çalıştırın.
.
Kod: 
Sub MUKERRER_BUL_SIL()
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Set shf = Sheets("Sayfa1"): son = shf.Cells(Rows.Count, 1).End(3).Row
shf.Columns("J:J").NumberFormat = "General": shf.Columns("K:L").Insert Shift:=xlToRight
    With shf.Range("K2:K" & son)
        .Formula = "=A2&B2&C2&D2&E2&F2&G2&H2&I2&J2": .Value = .Value
    End With
    With shf.Range("L2:L" & son)
        .Formula = "=COUNTIF($K$2:K2" & ",K2)": .Value = .Value
    End With
shf.Range("A1:L1").AutoFilter Field:=12, Criteria1:=">1"
shf.Range("A2:J" & son).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
[COLOR="Red"]On Error Resume Next[/COLOR]
shf.Range("A1:L1").AutoFilter
shf.Columns("K:L").Delete Shift:=xlToLeft
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
[B]End Sub[/B]
 
Ömer BARAN' Alıntı:
Merhaba.

Öncelikle profilinizdeki Ms.Excel versiyon bilgisini güncellemenizi hatırlatayım.

Sorunuzda "teke düşürme" demişsiniz ama, örnek belgede mükerrerlerin tümünün silinmesini istemişsiniz.
Aşağıdaki şekilde işlem yaptığınızda mükerrerler teke düşürülmez, tümü silinir.

-- Sayfanın alt tarafında açıklama yapmak için kullandığınız birleştirilmiş hücrelerdeki birleştirmeyi kaldırın ve içeriğini silin,
-- Alt taraftan Sayfa1'in adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
-- Açılan VBA ekranında sağdaki boş alana aşağıdaki kod'u yapıştırın,
-- Kod'u çalıştırın.
.
Kod: 
Sub MUKERRER_BUL_SIL()
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Set shf = Sheets("Sayfa1"): son = shf.Cells(Rows.Count, 1).End(3).Row
shf.Columns("H:H").NumberFormat = "General": shf.Columns("I:J").Insert Shift:=xlToRight
    With shf.Range("I2:I" & son)
        .Formula = "=A2&B2&C2&D2&E2&F2&G2&H2": .Value = .Value
    End With
    With shf.Range("J2:J" & son)
        .Formula = "=COUNTIF($I$2:$I$" & son & ",I2)": .Value = .Value
    End With
shf.Range("A1:J1").AutoFilter Field:=10, Criteria1:=">1"
shf.Range("A2:J" & son).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
shf.Range("A1:J1").AutoFilter
shf.Columns("I:J").Delete Shift:=xlToLeft
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı.", vbInformation, "..::.. Ömer BARAN ..::.."
[B]End Sub[/B]
Genişletmek için tıkla ...

Ömer BARAN bey öncelikle ilgilendiğiniz için teşekkür ederim.
Sanırım yanlış anlaşıldığım için "tümünü sil" için kod vermişsiniz.

Tümünü silme ve teke düşürme kısmına fazla girmeden neticeye şöyle çıkabiliriz şimdi sizin kodunuz tümünü sildi. Tekini bana bırakması gerekli.

+ Yeni farkettim.
İlk 5-6 stun da aynı değerler var diyelim fakat birinde ekstradan bir bilgi daha olmasına rağmen onuda siliyor.

Daha detaylı örnek buyrun: http://s8.dosya.tc/server5/5z7lto/ornek.xlsx.html
 
Son düzenleme:
Tekrar merhaba.

Yeni belgenizin yapısı diğerinden farklı.

Cevaplarımın altındaki İMZA bölümünde de belirttiğim gibi ve
forumda soruların çözümüne destek veren tüm üye ve yöneticilerin ortak isteği,
soruların gerçek belgeyle aynı yapıda örnek belge üzerinden sorulması.

Bu tür sorunların olmaması bakımından; sorularınızı gerçek belgeyle aynı yapıda ve
gerçek belgedeki verileri temsil edebilecek nitelikte örnek veriler içeren örnek belge üzerinden sorarsanız daha hızlı ve net çözüme ulaşırsınız.

Önceki cevabımdaki kod'u güncelledim, sayfayı yenileyerek kod'un yeni haline bakınız.
.
 
Alternatif kod olsun.

Kod: 
Sub Benzersiz()
son = Cells(Rows.Count, 1).End(3).Row
a = Range("A2:J" & son)
Set d = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For x = 1 To UBound(a)
    deg = ""
    For y = 1 To UBound(a, 2)
        deg = deg & a(x, y)
    Next y
    If Not d.exists(deg) Then
        say = say + 1
        d(deg) = say
        For y = 1 To UBound(a, 2)
            b(say, y) = a(x, y)
        Next y
    End If
Next x
Application.ScreenUpdating = 0
Range("A2:J" & Rows.Count).ClearContents
[A2].Resize(say, UBound(a, 2)) = b
Application.ScreenUpdating = 1
MsgBox "işlem tamam.", vbInformation
End Sub
 
İlk mesajınızda excel 2016 olarak belirtmişsiniz.

Yeni versiyonlarda VERİ menüsünün altında YİNELENENLERİ KALDIR seçeneği bulunuyor. Çok hızlı bir şekilde istediğiniz sonuca ulaşabilirsiniz.
 
Ömer BARAN' Alıntı:
Tekrar merhaba.

Yeni belgenizin yapısı diğerinden farklı.
Genişletmek için tıkla ...

Ömer bey aslında ilk mesajımda altını çizerek belirttiklerim ile son gönderdiğim dosya yapısında yapılmak istenenler aynıydı. Dosyayı sıfırdan yaptığım için eksik kalmış olabilir.

Korhan Ayhan' Alıntı:
İlk mesajınızda excel 2016 olarak belirtmişsiniz.

Yeni versiyonlarda VERİ menüsünün altında YİNELENENLERİ KALDIR seçeneği bulunuyor. Çok hızlı bir şekilde istediğiniz sonuca ulaşabilirsiniz.
Genişletmek için tıkla ...

Korhan bey tam olarak istediğim o değil bahsettiğiniz sutunlardan tek tek silme işlemi, fakat ilgin için sevindim. Teşekkürler.

Ziynettin' Alıntı:
Alternatif kod olsun.
[/CODE]
Genişletmek için tıkla ...

Aradığım tam da buydu. Ziynettin bey çok teşekkürler.
 
Son düzenleme:
Verdiğim kod'da bir sorun yok.

Son örnek belgenizde sadece 4'üncü satırın silinmesi lazım.

Kod'un ikinci çalışmasında olan şey verilerin silinmesi değil, filtre nedeniyle satırların gizlenmesi.

Önceki cevabıma buna ilişkin bir satır ekledim (kırmızı renklendirdiğim satır).
Sayfayı yenileyerek önceki cevabımı kontrol edin.

Tekrar deneyin isterseniz.
.
 
Herkese tekrar merhaba, Ziynettin beyin paylaştığı alttaki macro tam da isteğim doğrultusunda tüm satırı kontrol edip, birebir benzeri var ise satırı teke düşürmekte. Peki tüm satırı değil de sadece ilk iki (A ve B) stununu kontrol ettirip, verisi az satırları silip en çok olanı tek satırı ise bize saklatacak şekilde nasıl işlem yapabiliriz? İlginize şimdiden sonsuz teşekkür ederim.

Örnekte şöyle: http://s8.dosya.tc/server5/0k0ret/ornek.xlsx.html

Ziynettin' Alıntı:
Alternatif kod olsun.

Kod: 
Sub Benzersiz()
son = Cells(Rows.Count, 1).End(3).Row
a = Range("A2:J" & son)
Set d = CreateObject("scripting.dictionary")
ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For x = 1 To UBound(a)
    deg = ""
    For y = 1 To UBound(a, 2)
        deg = deg & a(x, y)
    Next y
    If Not d.exists(deg) Then
        say = say + 1
        d(deg) = say
        For y = 1 To UBound(a, 2)
            b(say, y) = a(x, y)
        Next y
    End If
Next x
Application.ScreenUpdating = 0
Range("A2:J" & Rows.Count).ClearContents
[A2].Resize(say, UBound(a, 2)) = b
Application.ScreenUpdating = 1
MsgBox "işlem tamam.", vbInformation
End Sub
Genişletmek için tıkla ...
 
....

Kod: 
Sub Mükerrer()
son = Cells(Rows.Count, 1).End(3).Row
a = Range("A2:H" & son)
Set d = CreateObject("Scripting.Dictionary")
ReDim b(1 To UBound(a), 1 To 9)
For i = 1 To UBound(a)
    say = say + 1
    For y = 1 To UBound(a, 2)
        If a(i, y) <> "" Then n = n + 1
    Next y
    b(say, 1) = a(i, 5)
    If n > b(say, 9) Then b(say, 2) = n
    n = 0
Next i
tbl = Array(b)
d.RemoveAll
Erase b
say = 0
For i = 1 To UBound(a)
    deg = tbl(0)(i, 1)
    If deg <> "" Then
        If d.exists(deg) Then
            If tbl(0)(i, 2) > tbl(0)(d(deg), 2) Then d(deg) = i
        Else
            d(deg) = i
        End If
    End If
Next i
ReDim b(1 To UBound(a), 1 To 8)
For Each v In d.items
    say = say + 1
    For y = 1 To UBound(a, 2)
        b(say, y) = a(v, y)
    Next y
Next v
Range("A2:H" & son).ClearContents
[A2].Resize(say, 8) = b
MsgBox "İşlem tamam.", vbInformation
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst