Aynı Verileri O veri Adı Altındaki Sheet'te Toplamak

[kbeser19]

Merhaba Arkadaşlar,

Data sayfasının "A" sütününde yer alan verilerden aynılarını alıp farklı bir sheet olusturucak. Fakat bu sheet bu aynı olan verilerin adını taşıycak ve o verinin satırını aynı sekilde o sheet tasıyacak. Veriler "Ahmet" ise sheet te "Ahmet" adında olucak ve data sheetindeki "A" sutününde yer alan her farklı veri için bu işlemi gerçekleştircek. Bu konuda yardımlarını rica ederim.

Not: Daha öncenden buna benzer bi vb kod parçacığı paylaşılmıstı ama bi türlü bulamadım.

Teşekkürler.

 

[N.Ziya Hiçdurmaz]

yanıt

Sub sayfaacaktar()
Application.DisplayAlerts = False
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> Sheets("Data").Name Then
            Sheets(i).Delete
        End If
    Next
Application.DisplayAlerts = True
    For i = 1 To Sheets.Count
    For sat = 2 To Sayfa1.Cells(65536, "a").End(xlUp).Row
        If WorksheetFunction.CountIf(Sayfa1.Range("a1:a" & sat), Sayfa1.Cells(sat, "a")) = 1 Then
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Sayfa1.Cells(sat, "a").Value
        End If
    Next
    Next
    son = Cells(65536, "a").End(xlUp).Row
    For i = 1 To Sheets.Count
    For sat = 2 To Sayfa1.Cells(65536, "a").End(xlUp).Row
        If Sheets(i).Name = Sayfa1.Cells(sat, "a").Value Then
            Sayfa1.Cells.Copy Sheets(i).[a1]
        End If
    Next
    Next
    
    For i = 1 To Sheets.Count
    For sat = Cells(65536, "a").End(xlUp).Row To 2 Step -1
        If Sheets(i).Name <> Sheets(i).Cells(sat, "a").Value And Sheets(i).Name <> Sayfa1.Name Then
            Sheets(i).Cells(sat, "a").EntireRow.Delete
        End If
    Next
    Next
End Sub

 

[kbeser19]

Eline bilgine sağlık. Çok teşekkür ederim.