Örnek Dosya Sütundaki Verileri İlgili Sayfalara Aktarmak

Sub Emre()
    Dim Sayfa$, a%, i&
    Application.ScreenUpdating = False
    For a = 2 To Worksheets.Count
        Sheets(a).Range("A2:I10000").Delete Shift:=xlUp
    Next a
    For i = 2 To Sayfa1.Range("B65536").End(3).Row
        Sayfa = Sayfa1.Cells(i, "B").Value
        If Not SayfaVarMi(Sayfa) Then
            Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Sayfa
            Sayfa1.Rows(1).Copy ActiveSheet.Rows(1)
        End If
        If Sayfa1.Cells(i, 2).Value = Sayfa Then
            Sayfa1.Range("A" & i & ":I" & i).Copy _
            Sheets(Sayfa).Range("A" & Sheets(Sayfa).Range("A65536").End(3).Row + 1)
        End If
    Next i
    Sayfa1.Activate
    MsgBox "İşlem Tamamlandı.", vbInformation, "Www.ExcelTurkey.Com"
    Application.ScreenUpdating = True
    i = Empty: a = Empty: Sayfa = vbNullString
End Sub

Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function