1 sayfadan 1. sayfa

Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

İletiTarih: 24 May 2019 17:08
aytekketya
Merhabalar,

Büyük bir datam var. Bu datada mükerrer olanları bulup başka bir sayfaya aktarıp orada kontrol etmek istiyorum.

Datadaki hücreleri birleştirip sonra arayacak ve sen sonunda listeleyecek bir makroya ihtiyacım var.

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

Cevap: Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

İletiTarih: 25 May 2019 17:32
şahin
Ekte

MükerrerKayıtBul.rar

Cevap: Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

İletiTarih: 10 Haz 2019 09:26
aytekketya
Merhaba Şahin bey,

Süper olmuş. Elinize sağlık. Teşekkürler şkşk

Cevap: Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

İletiTarih: 10 Haz 2019 09:43
aytekketya
şahin yazdı:Ekte

MükerrerKayıtBul.rar


Merhaba Şahin Bey,

Makro çalışıyor ama 20000 satır olduğundan excel "not responding" hatası veriyor ve kilitleniyor excel. Bunu nasıl çözebilirim? Teşekkürler.

Cevap: Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

İletiTarih: 10 Haz 2019 20:29
Feyzullah
Yüksek satırlarda ADO ile çalışmak daha hızlıdır. ADO makro kodunuz aşağıdadır. Sayfa adı ve verilerin başladğı sıra değişmemelidir.

Kod: Tümünü seç
Sub excel()
    Set con = VBA.CreateObject("adodb.Connection")
    Set rs = VBA.CreateObject("adodb.Recordset")
    son = Worksheets("Mukerrer").Cells(Rows.Count, 1).End(xlUp).Row + 2
    Worksheets
("Mukerrer").Range("A2:D" & son).ClearContents
        con
.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook
.FullName & ";extended properties=""Excel 12.0;hdr=no"""
        sorgu = "select  f1,f2,f3,f2 from [Sheet1$B4:D] where f2 in "
            sorgu = sorgu & "(SELECT f2 from [Sheet1$B4:D] group by f2 having count(f1) > 1 order by f2)"
                rs.Open sorgu, con, 1, 1
                    If rs
.RecordCount > 0 Then Worksheets("Mukerrer").Range("A3").CopyFromRecordset rs
                rs
.Close
                
        sorgu 
= "select  f1,f2,f3,f1 & f2 from [Sheet1$B4:D] where f1 & f2 in "
            sorgu = sorgu & "(SELECT f1 & f2 from [Sheet1$B4:D] group by f1 & f2 having count(f1) > 1 order by f1 & f2)"
                rs.Open sorgu, con, 1, 1
                son 
= Worksheets("Mukerrer").Cells(Rows.Count, 1).End(xlUp).Row + 2
                    If rs
.RecordCount > 0 Then Worksheets("Mukerrer").Range("A" & son).CopyFromRecordset rs
                rs
.Close
                
        sorgu 
= "select  f1,f2,f3,f2 & f3 from [Sheet1$B4:D] where f2 & f3 in "
            sorgu = sorgu & "(SELECT f2 & f3 from [Sheet1$B4:D] group by f2 & f3 having count(f1) > 1 order by f2 & f3)"
                rs.Open sorgu, con, 1, 1
                son 
= Worksheets("Mukerrer").Cells(Rows.Count, 1).End(xlUp).Row + 2
                    If rs
.RecordCount > 0 Then Worksheets("Mukerrer").Range("A" & son).CopyFromRecordset rs
                rs
.Close
                con
.Close
    MsgBox 
"İşlem Tamamlandı", vbInformation, "www.exceldestek.com"
End Sub

Cevap: Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

İletiTarih: 11 Haz 2019 09:20
aytekketya
Merhaba Feyzullah bey,

Kodu denedim. Ancak yaklaşık 1 saat çalıştı ve sonuç vermedi. "Cevap vermiyor" hatası aldığından görev yöneticisinden kapattım.

Başka bir öneriniz var mıdır?

İlginize teşekkür ederim.

Cevap: Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

İletiTarih: 11 Haz 2019 09:33
Feyzullah
Kendi verilerinizde mi bir saat çalıştı yoksa ekli dosya mı

Cevap: Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

İletiTarih: 11 Haz 2019 09:51
aytekketya
Kendi verilerimle. Yaklaşık 20000 satırlık. Bilginize,

Cevap: Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

İletiTarih: 11 Haz 2019 18:55
feraz
Birde bunu deneyiniz.Hata olsursa sıralama için yaptığım alttaki kodları siliniz.

.Range("A3").Resize(say, 4).Sort .Range("A3")
.Range("A" & son_Mukerrer).Resize(say + son_Mukerrer, 4).Sort .Range("A" & son_Mukerrer)
.Range("A" & son_Mukerrer).Resize(say + son_Mukerrer, 4).Sort .Range("A" & son_Mukerrer)


Kod: Tümünü seç
Option Compare Text

Sub Al()

    Call test(ThisWorkbook.Sheets("Sheet1"), ThisWorkbook.Sheets("Mukerrer"), 1)
    Call test(ThisWorkbook.Sheets("Sheet1"), ThisWorkbook.Sheets("Mukerrer"), 2)
    Call test(ThisWorkbook.Sheets("Sheet1"), ThisWorkbook.Sheets("Mukerrer"), 3)

End Sub


Kod: Tümünü seç
Sub test(sayfaad1 As Worksheet, sayfaad_Mukerrer As Worksheet, kac As Byte)

   Dim A, son_Mukerrer As Long

   Set d = CreateObject("scripting.dictionary")
   
With CreateObject("scripting.dictionary")
   .comparemode = vbTextCompare
   
Application.ScreenUpdating = False
'--------------------------------------------------------------------------------
    If kac = 1 Then 'ilk adim icin
        sayfaad_Mukerrer.Range("A3:D" & Rows.Count).ClearContents
    ElseIf kac = 2 Then
        son_Mukerrer = sayfaad_Mukerrer.Cells(Rows.Count, 2).End(3).Row
        sayfaad_Mukerrer.Range("A" & son_Mukerrer + 1 & ":D" & Rows.Count).ClearContents
    ElseIf kac = 3 Then
        son_Mukerrer = sayfaad_Mukerrer.Cells(Rows.Count, 2).End(3).Row
        sayfaad_Mukerrer.Range("A" & son_Mukerrer + 1 & ":D" & Rows.Count).ClearContents
    End If
  '--------------------------------------------------------------------------------
'*********************************************************************************
           
    son_Sheet1 = sayfaad1.Cells(Rows.Count, 2).End(3).Row
     A = sayfaad1.Range("B4:D" & son_Sheet1).Value

        If kac = 1 Then 'ilk adim icin
            For i = 1 To UBound(A)
                krt = A(i, 2)
                d(A(i, 2)) = d(krt) + 1
                If d(krt) > 1 Then .Item(krt) = A(i, 1)
            Next i
           
            If .Count > 0 Then
                ReDim B(1 To UBound(A), 1 To 4)
                For i = 1 To UBound(A)
                    krt = A(i, 2)
                    If .exists(krt) Then
                        say = say + 1
                        For y = 1 To 3
                            B(say, y) = A(i, y)
                            B(say, 4) = A(i, 2)
                        Next y
                    End If
                Next i
           End If
   End If
'*********************************************************************************

   If kac = 2 Then 'ikinci adim icin
        For i = 1 To UBound(A)
            krt = A(i, 1) & "|" & A(i, 2)
            d(krt) = d(krt) + 1
            If d(krt) > 1 Then
                .Item(krt) = A(i, 1) & "|" & A(i, 2)
            End If
        Next i
        If .Count > 0 Then
            ReDim B(1 To UBound(A), 1 To 4)
            For i = 1 To UBound(A)
                krt = A(i, 1) & "|" & A(i, 2)
                If .exists(krt) Then
                    say = say + 1
                    For y = 1 To 3
                        B(say, y) = A(i, y)
                        B(say, 4) = A(i, 1) & A(i, 2)
                    Next y
                End If
            Next i
     End If
   End If
'*********************************************************************************

     If kac = 3 Then 'ücüncü adim icin
         For i = 1 To UBound(A)
            krt = A(i, 2) & "|" & A(i, 3)
            d(krt) = d(krt) + 1
            If d(krt) > 1 Then
                .Item(krt) = A(i, 2) & "|" & A(i, 3)
            End If
        Next i
        If .Count > 0 Then
            ReDim B(1 To UBound(A), 1 To 4)
            For i = 1 To UBound(A)
                krt = A(i, 2) & "|" & A(i, 3)
                If .exists(krt) Then
                    say = say + 1
                    For y = 1 To 3
                        B(say, y) = A(i, y)
                        B(say, 4) = A(i, 2) & A(i, 3)
                    Next y
                End If
            Next i
         End If
     End If
'*********************************************************************************
    With sayfaad_Mukerrer
        If kac = 1 Then 'ilk adim icin
            .Range("A3").Resize(say, 4) = B
            .Range("A3").Resize(say, 4).Sort .Range("A3")
           
        ElseIf kac = 2 Then 'ikinci adim icin
            .Range("A" & son_Mukerrer + 2).Resize(say, 4) = B
             son_Mukerrer = .Cells(Rows.Count, 2).End(3).End(3).Row
            .Range("A" & son_Mukerrer).Resize(say + son_Mukerrer, 4).Sort .Range("A" & son_Mukerrer)
        ElseIf kac = 3 Then 'ücüncü adim icin
            .Range("A" & son_Mukerrer + 2).Resize(say, 4) = B
             son_Mukerrer = .Cells(Rows.Count, 2).End(3).End(3).Row
            .Range("A" & son_Mukerrer).Resize(say + son_Mukerrer, 4).Sort .Range("A" & son_Mukerrer)
        End If
    End With
End With
   
  Application.ScreenUpdating = True

Erase A: Erase B: Set sayfaad1 = Nothing: Set sayfaad_Mukerrer = Nothing: Set d = Nothing

End Sub

Cevap: Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

İletiTarih: 11 Haz 2019 19:03
feraz
Bunu deneyiniz.

Cevap: Cevap: Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

İletiTarih: 12 Haz 2019 09:40
aytekketya
feraz yazdı:Bunu deneyiniz.


Merhaba Feraz,

En hızlısı bu oldu :shock: çok teşekkür ederim size ve herkese şkşk

Cevap: Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

İletiTarih: 12 Haz 2019 09:51
feraz
Merhaba.

Rica ederiz.Kolay gelsin.