• DİKKAT

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

Yinelenen Satırları Silme

A

Arifce

Katılım
1 Haziran 2009
Mesajlar
6
Excel Vers. ve Dili
xp
Arkadaşlar;

Bir sütunda yinelenen birden çok değer varsa, bu sütundaki yinelenen değerlerden sadece bir tanesini muhafaza etmesini istiyorum fakat bu değeri tutarken aynı satırdaki bilgileride kaybetmemesini istiyorum.

YAni bir sutnda yinenlenen değer varsa bunlardan sadece birtanesini satırıyla beraber olduğu gibi braksın, diğerlerini satırlarıyla beraber silsin...

emeklerinize teşekkürler


(birde benim elimde birhayli excell döküman var, bunları size nasıl ulaştırım ve sizlerin insanların faydasına nnasıl tekrar sunarız, yardımcu olursanız sevinirim )
 
Merhaba,

Sitede mükerrer kontrol ile ilgili bir çok örnek dosya var.Soru sormadan öncesinde lütfen arama yapın.
 
1. isteğim ) bir sutnda yinenlenen değer varsa bunlardan sadece birtanesini satırıyla beraber olduğu gibi braksın, diğerlerini satırlarıyla beraber silsin... (bunla ilgili bir kod yardımı istiyorum)


1. isteğim ) elimdeki arşivimi size nasıl ulaştırırım, bunları tekrar insanların hizmetine nasıl sunarım



saollun kolay gelsin
 
eğer bu sütunda "b" değerinden 10 tane varsa 9 tanesini satırlrıyla beraber silecek

eğer bu sütunda "b" değerinden 10 tane varsa 9 tanesini satırlrıyla beraber silecek
(Yani bir sütun da benzer değerlerden birtanesi kalacak, diğerleri satırlarıyla beraber silinecek)

Arkaşlar örnek bir dosya gönderiyorum Yardımlarınız için teşekkürler
 
Dosyanızı 2003 formatında yollarsanız daha çabuk cevap alabilirsiniz.Hekesde 2007 yok.:cool:
 
2007 kullanıyorsanız veri içeren tüm aralığını mouse ile seçin Veri Sekmesinde -Yinelenlenleri kaldırı ve oradan istenilen sütunu seçin,böylece benzersiz yeni listeniz olmuş olacaktır.
 
Kodlar aşağıda :cool:
Kod: 
Sub teke_indir()
Dim i As Long
Sheets("Sayfa1").Select
For i = Cells(65536, "B").End(xlUp).Row To 5 Step -1
    If WorksheetFunction.CountIf(Range("B" & i & ":B4"), Cells(i, "B").Value) > 1 Then
        Range("B" & i).EntireRow.Delete (xlUp)
    End If
Next i
MsgBox "Mükerrer kayıtlar silinmiştir."
End Sub
 
Çok teşekkür ederim

Yazılım süper bir buluş
onu kullananlar süperler

İyiki varsınız...
 
Alternatif bir kod.
Kod: 
Sub tekrarEdenSatirlariSil()
    'veyselemre
    Dim rSil As Range, huc As Range, col As New Collection
    On Error Resume Next
    For Each huc In Range([b4], [b4].End(xlDown))
        col.Add huc.Value, huc.Value
        If Err > 0 Then
            Err = 0
            If rSil Is Nothing Then
                Set rSil = huc
            Else
                Set rSil = Union(rSil, huc)
            End If
        End If
    Next
    On Error GoTo 0
    If Not rSil Is Nothing Then rSil.EntireRow.Delete
    Set col = Nothing
    Set rSil = Nothing
    Set huc = Nothing
End Sub
 
Hayırlı Sabahlar Arkadaşlar

Konuya benzer bir sorum olacak;

alt alta B ve C sütunlarında Örneğin

B6 hücresindeki değer 2009 C6 Hücresindeki Değer 1231
B7 hücresindeki değer 2009 C7 Hücresindeki Değer 1231
B8 hücresindeki değer 2009 C8 Hücresindeki Değer 1231

elimde yaklaşık 9000 satır var Bu durumdaki satırları teke düşürmek için bir macro önerebilirmisiniz
 
Veyselemre Beyin kodlarını aşağıdaki gibi revize edip kullanabilirsiniz.

Kod: 
Sub Tekrar_Edenleri_Sil()
    Dim Veri As Range, Son As Long
    Dim Liste As New Collection, Alan As Range
    
    Son = Cells(Rows.Count, 2).End(3).Row
    
    On Error Resume Next
    
    For Each Veri In Range("B6:B" & Son)
        If Veri.Value <> "" Then
            Liste.Add Veri.Value & Veri.Offset(0, 1).Value, Veri.Value & Veri.Offset(0, 1).Value
            If Err > 0 Then
                Err = 0
                If Alan Is Nothing Then
                    Set Alan = Union(Veri, Veri.Offset(0, 1))
                Else
                    Set Alan = Union(Alan, Veri, Veri.Offset(0, 1))
                End If
            End If
        End If
    Next
    
    On Error GoTo 0
    
    If Not Alan Is Nothing Then Alan.Delete xlUp
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Selam, benimde benzer bir sorunum var ancak benim durumumda ben sadece yinelenen değerleri silmek benzersiz bir tane bırakmak istiyorum. Yani yinelenen satır silinmesin hücresi boş kalsın. Elimde 160 bin satırlık bir tablo var ve bunu bir türlü beceremedim.
Örnek dosya ekledim.

http://s4.dosya.tc/server3/8qdvbm/ORNEK.xlsx.html

Dosyam için bir resimde yükledim.

http://i.hizliresim.com/0y9Lm8.jpg

Yardımcı olabilecek arkadaşlara şimdiden çok teşekkür ederim.

NOT: Bu işlemi topluca değil her sütunu ayrı olarak da yapabilsem işimi görür. Yani A sütunundaki yinelenenleri kaldırıp aradaki boşlukları bıraksam yinede benim işimi görür diye düşünüyorum.
 

Ekli dosyalar

Son düzenleme:
Dosya ekte

Kod: 
Option Explicit
Sub Tablo()
Dim a(), b(), d As Object
Dim i As Long, Say As Long, y As Byte

Sheets("Sayfa1").Select
Application.ScreenUpdating = False

Set d = CreateObject("Scripting.Dictionary")
a = Range("A4:C22")
ReDim b(1 To UBound(a), 1 To 3)
    For i = 1 To UBound(a)
        For y = 1 To 3
            If Not d.exists(a(i, y)) Then
                Say = Say + 1
                d.Add a(i, y), Say
                b(i, y) = a(i, y)
            End If
        Next y
    Next i
    
Range("I4:K" & Rows.Count).ClearContents

If Say > 0 Then
    Range("I4").Resize(UBound(a), 3) = b
End If

Application.ScreenUpdating = True
MsgBox "İşleminiz tamam.", vbInformation
End Sub
 

Ekli dosyalar

Çok teşekkür ederim sayın Ziynettin. Makronuz bana ışık tuttu tüm çalışma sayfasına (160 bin satıra) uyarladım.
Tekrar tekrar teşekkürler.
 
Merhabalar

Benimde bir yinelenenleri teke düşürmek istediğim listem var,
B sütunundaki verilere göre mükerrer olnları tek kayda indirmem gerekiyor.
buradaki tüm formülleri denedim dosyama uyduramadım. İlk 22 satırı bırakıyor diğerlerinin tamamını siliyor.
dosyam ektedir yardımcı olabilir misiniz?
dosyada kayıt sayısı az, normalde 20 bin kaydı silmem gerekiyor
 

Ekli dosyalar

Merhaba,

Dosyanız ekte,


Kod: 
Option Explicit
Sub Benzersiz_B()
Dim a(), b(), d As Object, z As Double
Dim i As Long, Say As Long, k As Byte
z = TimeValue(Now)
Application.ScreenUpdating = False
Sheets("sayfa1").Select
    Set d = CreateObject("Scripting.Dictionary")
    a = Range("A1:P" & [a65000].End(xlUp).Row)
    For i = 1 To UBound(a)
        If Not d.exists(a(i, 2)) Then
            Say = Say + 1
            d(a(i, 2)) = Say
        End If
    Next i
  
    ReDim b(1 To d.Count, 1 To UBound(a, 2))
    For i = 1 To UBound(a)
        For k = 1 To UBound(a, 2)
            b(d(a(i, 2)), k) = a(i, k)
        Next k
    Next i
    
With Sheets("Sayfa2")
    .Cells.ClearContents
    .[A1].Resize(UBound(b), UBound(b, 2)) = b
    .[A2].Resize(UBound(b)).NumberFormat = "dd.mm.yyyy"
    .[L2].Resize(UBound(b)).NumberFormat = "dd.mm.yyyy"
    .[P2].Resize(UBound(b)).NumberFormat = "dd.mm.yyyy"
    .Select
End With
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM....!!!" & vbLf & vbLf & "       " & CDate(TimeValue(Now) - z), vbInformation
End Sub
 

Ekli dosyalar

Çok teşekkür ederim elinize sağlık,
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst