Benzersiz & Mükerrer

[semprass]

Arkadaşlar tekrardan merhaba.
Bu seferde sizlerden ekteki dosyada bulunan kayıtların benzersizlerin silinmesi
İkinci bir dosya mükerrer olan kayıtların sayfa2 ye taşınmasını istesem çokmu ayıp etmiş olurum sadece iki dosyacık.

 

[N.Ziya Hiçdurmaz]

Hangi sayfa hangi sütun belirtmemişsiniz.

 

[semprass]

belirtmeme gerek varmıydı özür dilerim

Komple satır taşınacak veya silinecek.
Mükerrerler (kaçtane var ise) taşınacak.
Benzersizlerde silinecek (Buda ikinci dosya)

Umarım açık olmuşumdur.

 

[Korhan Ayhan]

Selamlar,

Sorunuz hala açık değil ! Neden ?

Örnek olarak eklediğiniz iki excel dosyasının üç sayfasındada veriler var. Bu durumda hangi sayfadaki veriler silinecek yada aktarılacak ?

Belirtmediğiniz sürece bizler sadece tahmin yürütebiliriz. Umarım açıklayıcı olmuştur.

 

[semprass]

Selamlar,

Sorunuz hala açık değil ! Neden ?

Örnek olarak eklediğiniz iki excel dosyasının üç sayfasındada veriler var. Bu durumda hangi sayfadaki veriler silinecek yada aktarılacak ?

Belirtmediğiniz sürece bizler sadece tahmin yürütebiliriz. Umarım açıklayıcı olmuştur.

Kusura bakma kafam dalgın yanlış dosya SORRY. SO SORRY

 

[semprass]

Heh bide özür dilerim


İyi çalışmalar...

 

[semprass]

Ekteki dosyayı değiştirdim.

 

[Skorpiyon]

Sub BI_YERE_KADAR()
Dim a, b, c As Integer
b = 2
For a = 1 To 500
If Cells(a, 1).Value = "" Then
GoTo bitir
End If
For c = 1 To 500
If Cells(a, 1).Value = Cells(b, 1).Value Then
Cells(b, 1).Interior.ColorIndex = 3
Cells(a, 1).Interior.ColorIndex = 3
b = b + 1
Else
b = b + 1
End If
Next c
If a = a Then
b = b - 499 '499 rakamı üstteki FOR döngülerinden 1 eksik olacak.
End If
Next
bitir:
End Sub

Sayın Semprass,
Nasıl yaparım, nasıl yaparım diyerek, 2 saat kafa patlattıktan sonra geçen seferkinden farklı bir yöntemle, ulaşabildiğim son nokta burası ve tıkandım kaldım. Maalesef benim (Şimdilik) yapabildiğim bu. Dilerim sorununuza yardımcı olan bir arkadaş çıkar.

Artık verinin sayfada kaç tekrar ettiğinin önemi de yok, hepsini bulabiliyoruz.
İşin kötü tarafı siz ilk mesajlarınızdan birinde 35000 satır var demiştiniz. Bu komutlarla hadi 3000~5000, atıyorum 10.000 satırı halledin problem çıkmaz diyecem ama, 35000 satırda bu SAATLER sürer. Ve son olarak bu komutlarla zaten max.32766 satırı kontrol edebilir. Daha üzeri MUTLAK hata verir.

Bu noktada tıkandıktan sonra verilerin taşınması veya silinmesi ile maalesef uğraşamayacağım.

Saygılar, Şaban...

 

[veyselemre]

Arkadaşlar tekrardan merhaba.
Bu seferde sizlerden ekteki dosyada bulunan kayıtların benzersizlerin silinmesi
İkinci bir dosya mükerrer olan kayıtların sayfa2 ye taşınmasını istesem çokmu ayıp etmiş olurum sadece iki dosyacık.

Acaba ben mi yanlış anlıyorum. Benzersizlerin silinmesi ne demek? Verdiğiniz dosya adı ne? Benzersiz olanların silinmesi demek mukerrer kayıtlar kalsın demek, ben aynı olanların silinmesi diye anlayarak kodları yazdım? Ayrıca benzerlik kriteri olarak A sütunu alınmıştır.

Sub AyniOlanlarSilinsin()
son=[a65536].End(3).Row
Columns("A:G").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo
Range("H1").FormulaR1C1 = "=COUNTIF(C[-7],RC[-7])"
Range("H1").AutoFill Destination:=Range("H1:H" & son), Type:=xlFillDefault
Sut = "H"

Dim rForDelete As Range

        For Each c In Range(Cells(1, Sut), Cells(son, Sut))
            If c.Value > 1 Then
                If rForDelete Is Nothing Then
                    Set rForDelete = c
                Else
                    Set rForDelete = Union(rForDelete, c)
                End If
            End If
        Next
        
    If Not rForDelete Is Nothing Then rForDelete.EntireRow.Delete
Columns(Sut).Delete
End Sub

Sub MukerrerleriAktar()
On Error Resume Next
Application.DisplayAlerts = False
Sheets("mukerrer").Delete
Sheets("Sayfa1").Copy after:=Sheets("Sayfa1")
ActiveSheet.Name = "Mukerrer"
On Error GoTo 0
son = [a65536].End(3).Row
Columns("A:G").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo
Range("H1").FormulaR1C1 = "=COUNTIF(C[-7],RC[-7])"
Range("H1").AutoFill Destination:=Range("H1:H" & son), Type:=xlFillDefault
Sut = "H"

Dim rForDelete As Range
        For Each c In Range(Cells(1, Sut), Cells(son, Sut))
            If c.Value = 1 Then
                If rForDelete Is Nothing Then
                    Set rForDelete = c
                Else
                    Set rForDelete = Union(rForDelete, c)
                End If
            End If
        Next
        
    If Not rForDelete Is Nothing Then rForDelete.EntireRow.Delete
Columns(Sut).Delete
End Sub