• DİKKAT

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

Yinelenenleri Komple Kaldırma

  • Konbuyu başlatan Konbuyu başlatan enes309
  • Başlangıç tarihi Başlangıç tarihi
E

enes309

Katılım
2 Eylül 2016
Mesajlar
23
Excel Vers. ve Dili
Excel 2016
İyi Akşamlar. Excel 2016 kullanıyorum. A da yinelenenleri B ile beraber komple silmem lazım. Yani benzersizlerle işim var. Bunu yapmak mümkün mü?

Birde excele uzun sayı atınca 1,53648E+15 gibi oluyor. Bunu kapatabiliyor muyuz? Hepsinin başına ' koymak çok sıkıntı :)
 
veri sekmesinde yinelenenleri kaldır kısmına göz atın
 
Deneyiniz.

Kod: 
Sub BENZER_KAYITLARIN_TÜMÜNÜ_SİL()
    Dim X As Long, Say As Long, Alan As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    For X = 1 To Cells(Rows.Count, 1).End(3).Row
        Say = WorksheetFunction.CountIf([A:A], Cells(X, 1))
        If Say > 1 Then
            Columns(1).Replace What:=Cells(X, 1), Replacement:="", LookAt:=xlWhole
        End If
    Next
    
    On Error Resume Next
    Set Alan = Intersect(Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow, Columns(1).Resize(, 2))
    On Error GoTo 0
    
    If Not Alan Is Nothing Then Alan.Delete Shift:=xlUp
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Merhaba,

B,C,D sutünlarda yinelenleri komple kaldırmak istersek, kodlarda nasıl değişiklik yapabiliriz
 
Kendinize göre ayaralayın, abcd sütunları aynı olanları siler, biri kalır
Kod: 
Sub mukerrer()
For a = [a65536].End(3).Row To 1 Step -1
say = Evaluate("=SUMPRODUCT((A1:A" & a & "=A" & a & ")*(B1:B" & a & "=B" & a & ")*(C1:C" & a & "=C" & a & ")*(d1:d" & a & "=d" & a & "))")
If say > 1 Then Rows(a).Delete
Next
End Sub
 
tahsinanarat' Alıntı:
Kendinize göre ayaralayın, abcd sütunları aynı olanları siler, biri kalır
Kod: 
Sub mukerrer()
For a = [a65536].End(3).Row To 1 Step -1
say = Evaluate("=SUMPRODUCT((A1:A" & a & "=A" & a & ")*(B1:B" & a & "=B" & a & ")*(C1:C" & a & "=C" & a & ")*(d1:d" & a & "=d" & a & "))")
If say > 1 Then Rows(a).Delete
Next
End Sub
Genişletmek için tıkla ...

Kodlar çalışmadı
 
Son düzenleme:
Korhan Ayhan' Alıntı:
Deneyiniz.

Kod: 
Sub BENZER_KAYITLARI_SİL()
    For X = 1 To [A65536].End(3).Row
    SAY = WorksheetFunction.CountIf([A:A], Cells(X, 1))
    If SAY > 1 Then
    Columns(1).Replace What:=Cells(X, 1), Replacement:=""
    End If
    Next
    RANGE("A:B").SpecialCells(xlCellTypeBlanks).Delete  Shift:=xlUp
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...

Teşekkür ederim. Sadece A da işlem yapıyor. A dakileri komple silerken B aynen kalıyor. Belki B deki yinelenenleride siliyordur dedim onuda yapmadı.
A dakileri silerken B satırınıda sildirebilir miyiz ? veya o satırı komple sildirsekde olur diğerleri boş zaten. Tekrar teşekkür ederim
 
#4 nolu mesajımdaki kodu güncelledim. Verilerinizi yedekleyip tekrar deneyiniz.

Veriniz çoksa biraz bekletecektir.
 
Veri sayınız çok ise aşağıdaki kod daha hızlı sonuç verecektir.

Kod satır silme işlemi yapmıyor, fakat verileri tamamen tekrar etmeyen kayıtlardan liste oluşturup "C" sütunundan itibaren listeliyor.

Kod: 
Sub TEKRAR_ETMEYEN_KAYITLARI_LİSTELE()
    Dim SD As Object, Veri(), Dizi(), Son As Long, Say As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set SD = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, "A").End(3).Row
    Veri = Range("A1:B" & Son).Value
    
    For X = 1 To UBound(Veri, 1)
        SD.Item(Veri(X, 1)) = SD.Item(Veri(X, 1)) + 1
    Next
    
    ReDim Dizi(1 To 2, 1 To 1)
    
    For X = 1 To UBound(Veri, 1)
        Kriter = Veri(X, 1)
        If SD.Item(Veri(X, 1)) = 1 Then
            Say = Say + 1
            ReDim Preserve Dizi(1 To 2, 1 To Say)
            Dizi(1, Say) = Veri(X, 1)
            Dizi(2, Say) = Veri(X, 2)
        End If
    Next
    
    Range("C1").Resize(Say, 2) = Application.Transpose(Dizi)

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Deneyiniz.

Kod: 
Sub BENZER_KAYITLARIN_TÜMÜNÜ_SİL()
    Dim X As Long, Say As Long, Alan As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    For X = 1 To Cells(Rows.Count, 1).End(3).Row
        Say = WorksheetFunction.CountIf([A:A], Cells(X, 1))
        If Say > 1 Then
            Columns(1).Replace What:=Cells(X, 1), Replacement:="", LookAt:=xlWhole
        End If
    Next
    
    On Error Resume Next
    Set Alan = Intersect(Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow, Columns(1).Resize(, 2))
    On Error GoTo 0
    
    If Not Alan Is Nothing Then Alan.Delete Shift:=xlUp
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...

Korhan bey, merhaba

C,D,E sutünlarda yinelenleri komple kaldırmak istersek, kodlarda nasıl değişiklik yapabiliriz

Teşekkürler
 
Korhan Ayhan' Alıntı:
Veri sayınız çok ise aşağıdaki kod daha hızlı sonuç verecektir.

Kod satır silme işlemi yapmıyor, fakat verileri tamamen tekrar etmeyen kayıtlardan liste oluşturup "C" sütunundan itibaren listeliyor.

Kod: 
Sub TEKRAR_ETMEYEN_KAYITLARI_LİSTELE()
    Dim SD As Object, Veri(), Dizi(), Son As Long, Say As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set SD = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, "A").End(3).Row
    Veri = Range("A1:B" & Son).Value
    
    For X = 1 To UBound(Veri, 1)
        SD.Item(Veri(X, 1)) = SD.Item(Veri(X, 1)) + 1
    Next
    
    ReDim Dizi(1 To 2, 1 To 1)
    
    For X = 1 To UBound(Veri, 1)
        Kriter = Veri(X, 1)
        If SD.Item(Veri(X, 1)) = 1 Then
            Say = Say + 1
            ReDim Preserve Dizi(1 To 2, 1 To Say)
            Dizi(1, Say) = Veri(X, 1)
            Dizi(2, Say) = Veri(X, 2)
        End If
    Next
    
    Range("C1").Resize(Say, 2) = Application.Transpose(Dizi)

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...

Çok teşekkür ederim kodlar istediğim gibi oldu :) İkiside aynı kapıya çıkıyor. Çok veri olduğu için tavsiyenize uyup burdaki kodu kullanacam :)

Hocam bu kodu 10-20 satırda denediğimde mesela A da 1-1-2-2-3-4-5-6-7-8-9-10 yapıyorum B yede sallıyorum kafadan kodu çalıştırdığımda 3-4-5-6-7-8-9-10 diye B ile beraber C-D sütunlarına sıralıyo sorun yok ama benim 365.000 satırda yaptığımda sadece A dakileri C ve D sütunlarına 16.000 sırayla dizdi, sonrasında #YOK diye yazdı C ve D sütunlarında. B sütununa dokunmadı. Çok veri olduğu için mi böyle oldu acaba ? İlk verdiğin kodu çalıştırdım bekliyorum onda nasıl bir sonuç alacam yazarım
 
Son düzenleme:
Aşağıdaki kodu deneyiniz.

Kod: 
Sub TEKRAR_ETMEYEN_KAYITLARI_LİSTELE()
    Dim SD As Object, Veri(), Dizi(), Son As Long, Say As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set SD = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, "A").End(3).Row
    Veri = Range("A1:B" & Son).Value
    
    For X = 1 To UBound(Veri, 1)
        SD.Item(Veri(X, 1)) = SD.Item(Veri(X, 1)) + 1
    Next
    
    ReDim Dizi(1 To Son, 1 To 2)
    
    For X = 1 To UBound(Veri, 1)
        Kriter = Veri(X, 1)
        If SD.Item(Veri(X, 1)) = 1 Then
            Say = Say + 1
            ReDim Preserve Dizi(1 To Son, 1 To 2)
            Dizi(Say, 1) = Veri(X, 1)
            Dizi(Say, 2) = Veri(X, 2)
        End If
    Next
    
    Range("C1").Resize(Say, 2) = Dizi

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Aşağıdaki kodu deneyiniz.

Kod: 
Sub TEKRAR_ETMEYEN_KAYITLARI_LİSTELE()
    Dim SD As Object, Veri(), Dizi(), Son As Long, Say As Long

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set SD = CreateObject("Scripting.Dictionary")
    
    Son = Cells(Rows.Count, "A").End(3).Row
    Veri = Range("A1:B" & Son).Value
    
    For X = 1 To UBound(Veri, 1)
        SD.Item(Veri(X, 1)) = SD.Item(Veri(X, 1)) + 1
    Next
    
    ReDim Dizi(1 To Son, 1 To 2)
    
    For X = 1 To UBound(Veri, 1)
        Kriter = Veri(X, 1)
        If SD.Item(Veri(X, 1)) = 1 Then
            Say = Say + 1
            ReDim Preserve Dizi(1 To Son, 1 To 2)
            Dizi(Say, 1) = Veri(X, 1)
            Dizi(Say, 2) = Veri(X, 2)
        End If
    Next
    
    Range("C1").Resize(Say, 2) = Dizi

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...

Run-time error '1004' diye bir hata verdi hocam. Ama C-D sütunlarına almış birazını. Hatanın nedenini nasıl bulabilirim?

Biraz araştırdım. Adımla yaptım. Sarı renk oldu kodların en basındaki '' Sub TEKRAR_ETMEYEN_KAYITLARI_LİSTELE() '' kısmı, tabi anlamadım sonra debug kısmından run to cursor yaptım. Set SD = CreateObject("Scripting.Dictionary") da diğeriyle beraber kırmızı oldu. Sanırım iki yerde hata var
 
Son düzenleme:
Moduldeki eski kodlari silip son verdigim kodu deneyin.
 
Korhan Ayhan' Alıntı:
Moduldeki eski kodlari silip son verdigim kodu deneyin.
Genişletmek için tıkla ...

yine işlemin yarısında aynı hataları verdi ''application-defined or object-defined error'' 97 bin sıra yaptı işlemi bitirmedi. Excelde mi sorun var bilemedim. Size dosyamı atsam bakabilir misiniz? Çözümü nette falanda bulamadım
 
Dosyanızı mail adresime gönderin. İnceleyip bilgi veririm.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst