Soru Sütundaki verileri ayrı sayfalara aktarmak

[hadromer]

Merhaba,
A-B-C-D-E sütunlarından oluşan verilerim var.
B sütununda yer alan veri gruplarını her gruba özgü yeni sayfa oluşturup taşımak istiyorum. Sayfa ismi ise veri grubu hangi isimden oluşuyorsa o olacak.
Örneğin B2-B13 arası "acat" adlı grup. A-B-C-D-E sütunları da dahil olmak üzere acat adlı yeni sayfaya kopyalanacak. Örnek fotoğrafa yapılmak isteneni işaretledim.
Örnek dosya ekledim.
yardımcı olabilir misiniz ?
teşekkür ederim.

 

[ÖmerBey]

Merhaba,
Dosyanızın yedeğini aldıktan sonra deneyiniz.

Sub kod()
Dim AV As Worksheet, s2 As Worksheet
Set AV = Sheets("Ana Veri")
bas = 2
grp = AV.Cells(bas, "B")
On Error Resume Next
Application.ScreenUpdating = False
For a = bas To AV.Cells(Rows.Count, "B").End(3).Row
    If AV.Cells(a, "B") <> AV.Cells(a + 1, "B") Then
        Set s2 = Sheets(grp)
        If s2 Is Nothing Then
            Sheets.Add After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = grp
            Set s2 = Sheets(grp)
        End If
        AV.Range(AV.Cells(bas, "A"), AV.Cells(a, "E")).Copy s2.Cells(Rows.Count, "A").End(3)(2, 1)
        bas = a + 1
        grp = AV.Cells(bas, "B")
        Set s2 = Nothing
    End If
Next
AV.Activate
Application.ScreenUpdating = True
MsgBox "Tamam."
End Sub

 

[hadromer]

Merhaba,
Dosyanızın yedeğini aldıktan sonra deneyiniz.

Sub kod()
Dim AV As Worksheet, s2 As Worksheet
Set AV = Sheets("Ana Veri")
bas = 2
grp = AV.Cells(bas, "B")
On Error Resume Next
Application.ScreenUpdating = False
For a = bas To AV.Cells(Rows.Count, "B").End(3).Row
    If AV.Cells(a, "B") <> AV.Cells(a + 1, "B") Then
        Set s2 = Sheets(grp)
        If s2 Is Nothing Then
            Sheets.Add After:=Sheets(Sheets.Count)
            Sheets(Sheets.Count).Name = grp
            Set s2 = Sheets(grp)
        End If
        AV.Range(AV.Cells(bas, "A"), AV.Cells(a, "E")).Copy s2.Cells(Rows.Count, "A").End(3)(2, 1)
        bas = a + 1
        grp = AV.Cells(bas, "B")
        Set s2 = Nothing
    End If
Next
AV.Activate
Application.ScreenUpdating = True
MsgBox "Tamam."
End Sub

Omer Bey cok tesekkur ederim. istedigim gibi calisti

 

[ÖmerBey]

Rica ederim,
İyi çalışmalar...