Mükerrer bilgileri yeni sayfaya kopyalama

[Zafer GÜL]

Merhaba,
Forumda daha öce açılmış olan konuları biraz inceledim ancak tam olarak ihtiyacıma cevap olacak bir makro göremedim. (Çok fazla var)
Yaklaşık 3000 satırlık bir listem var. Bu listede Sayfa1 C kolonundaki sicil numarasına göre sorgulama yaparak mükerrer olan sicillerin olduğu satırların hepsini 2.ci sayfaya taşımak istiyorum. (Satır A : DD arasıda olabilir.)

Mümkün ise aşağıdaki şekilde yapmak istiyorum.

* Makroyu çalıştırdığımda yeni sayfa açılacak, açılan sayfanın ismi Sayfa1 birinci satır C kolonundaki hücredeki metin olacak. Ör: "SİCİL"
* Sayfa1'de 1 satırda bulunan liste başlıkları Sayfa2 birinci satıra kopyalanacak.
* C Kolonunda bulunan siciller sorgulanarak birden fazla olanların bulunduğu satırlar yeni sayfaya kopyalanacak. (kaç tane ise)
* Bulunan satırlar kopyalandıktan sonra C kolonu küçükten büyüğe doğru sıralamak istiyorum.

* 2013 Türkçe versiyon kullanıyorum.

Biraz detaylı istedim çünkü benzer şekilde sorgulama yaptıracağım 5-6 kolon daha olacak. Onları sizin cevaplarınızdan faydalanarak çözmeye çalışacağım.
Saygılar,

 

[Ömer]

Merhaba,

Sorunuzu destekleyen 15-20 satırlık örnek bir çalışma hazırlayıp dosya içerisinde olmasını istediğinizide manuel hazırlayarak konuyu açıklamanızı rica ederim.

www.dosya.tc

.

 

[Zafer GÜL]

Yanıt

Merhaba Ömer bey,

Örnek olarak istediğiniz dosyayı 19.04.2017 de gönderdim, yardımınızı bekliyorum.
Saygılar,

 

[Ömer]

Mesaj olarak bana gelmedi.

Dosyayı siteye yükledikten sonra indirme linkini burada paylaşmanızı rica ederim.

.

 

[Zafer GÜL]

Link

Pardon, acemilik işte

http://s3.dosya.tc/server11/1p53nv/Liste.xlsx.html

 

[Ömer]

Bu şekilde deneyin.

Sub Mukerrerleri_Listele()

    Dim d As Object, Ss As Worksheet, S1 As Worksheet, i As Long
    Dim deg, s, a1, sat As Long, c As Range, Adr As String
    
    Set Ss = Sheets("SİCİL")
    Set S1 = Sheets("Sayfa1")
    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    S1.Select
    
    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
        deg = Cells(i, "C")
        If Not d.exists(deg) Then
            s = Array(1, Cells(i, "C"))
            d.Add deg, s
        Else
            s = d.Item(deg)
            s(0) = s(0) + 1
            d.Item(deg) = s
        End If
    Next i
    
    Ss.Select
    Range("A2:IV" & Rows.Count).Clear
      
    a1 = d.items: sat = 2
    For i = 0 To d.Count - 1
        s = a1(i)
        If s(0) > 1 Then
            With S1.[C:C]
                Set c = .Find(s(1), , xlValues, xlWhole)
                If Not c Is Nothing Then
                    Adr = c.Address
                    Do
                        S1.Rows(c.Row).Copy Cells(sat, "A")
                        Cells(sat, "A") = sat - 1
                        sat = sat + 1
                    Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Adr
                End If
            End With
        End If
    Next i
    
    Application.ScreenUpdating = True

End Sub

.