[Yardım]  Mükerrer Kayıtları Bulup Başka Sayfaya Aktarma

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

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

İleti#1)  aytekketya » 24 May 2019 17:08

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.
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
aytekketya
Yeni Başlamış
 
Adı Soyadı:ali akın
Kayıt: 07 Mar 2014 14:56
Konum: kocaeli
Meslek: satış
Yaş: 39
İleti: 44
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: kocaeli

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

İleti#2)  şahin » 25 May 2019 17:32

Ekte

MükerrerKayıtBul.rar
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
şahin
Site Dostu
 
Kayıt: 30 Eyl 2016 21:24
Meslek: memur
Yaş: 30
İleti: 626
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: bursa

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

İleti#3)  aytekketya » 10 Haz 2019 09:26

Merhaba Şahin bey,

Süper olmuş. Elinize sağlık. Teşekkürler şkşk
Kullanıcı avatarı
aytekketya
Yeni Başlamış
 
Adı Soyadı:ali akın
Kayıt: 07 Mar 2014 14:56
Konum: kocaeli
Meslek: satış
Yaş: 39
İleti: 44
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: kocaeli

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

İleti#4)  aytekketya » 10 Haz 2019 09:43

ş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.
Kullanıcı avatarı
aytekketya
Yeni Başlamış
 
Adı Soyadı:ali akın
Kayıt: 07 Mar 2014 14:56
Konum: kocaeli
Meslek: satış
Yaş: 39
İleti: 44
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: kocaeli

REKLAM
Excel Logo XML Oluşturucu
Logo Object Designer ile Uyarlama

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

İleti#5)  Feyzullah » 10 Haz 2019 20:29

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
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
Feyzullah
Site Dostu
 
Adı Soyadı:mete han
Kayıt: 18 Ekm 2011 08:30
İleti: 648
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: OSMANİYE

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

İleti#6)  aytekketya » 11 Haz 2019 09:20

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.
Kullanıcı avatarı
aytekketya
Yeni Başlamış
 
Adı Soyadı:ali akın
Kayıt: 07 Mar 2014 14:56
Konum: kocaeli
Meslek: satış
Yaş: 39
İleti: 44
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: kocaeli

REKLAM
ETA - Excel Konsolide Raporlama
ETA Excel Personel Entegre Raporu

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

İleti#7)  Feyzullah » 11 Haz 2019 09:33

Kendi verilerinizde mi bir saat çalıştı yoksa ekli dosya mı
Kullanıcı avatarı
Feyzullah
Site Dostu
 
Adı Soyadı:mete han
Kayıt: 18 Ekm 2011 08:30
İleti: 648
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: OSMANİYE

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

İleti#8)  aytekketya » 11 Haz 2019 09:51

Kendi verilerimle. Yaklaşık 20000 satırlık. Bilginize,
Kullanıcı avatarı
aytekketya
Yeni Başlamış
 
Adı Soyadı:ali akın
Kayıt: 07 Mar 2014 14:56
Konum: kocaeli
Meslek: satış
Yaş: 39
İleti: 44
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: kocaeli

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

İleti#9)  feraz » 11 Haz 2019 18:55

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
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 17:36
Konum: Almanya
Meslek: İşçi
Yaş: 40
İleti: 5952
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

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

İleti#10)  feraz » 11 Haz 2019 19:03

Bunu deneyiniz.
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 17:36
Konum: Almanya
Meslek: İşçi
Yaş: 40
İleti: 5952
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray

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

İleti#11)  aytekketya » 12 Haz 2019 09:40

feraz yazdı:Bunu deneyiniz.


Merhaba Feraz,

En hızlısı bu oldu :shock: çok teşekkür ederim size ve herkese şkşk
Kullanıcı avatarı
aytekketya
Yeni Başlamış
 
Adı Soyadı:ali akın
Kayıt: 07 Mar 2014 14:56
Konum: kocaeli
Meslek: satış
Yaş: 39
İleti: 44
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: kocaeli

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

İleti#12)  feraz » 12 Haz 2019 09:51

Merhaba.

Rica ederiz.Kolay gelsin.
Kullanıcı avatarı
feraz
Site Dostu
 
Kayıt: 19 May 2014 17:36
Konum: Almanya
Meslek: İşçi
Yaş: 40
İleti: 5952
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: Aksaray


Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: AhrefsBot, Bing[Bot], Yandex[Bot] ve 3 misafir

Bumerang - Yazarkafe