Kriterlere göre verileri diğer sayfaya gönderme?

[energy34]

Arkadaşlar ekteki dosyada da yazdım ilk sayfadaki verilerin tamamında isim ve soyisim filtresi yaparak yeni sayfaya gönderme nasıl yapabilirim?
yardımlarınızı bekliyorum.

 

[Orion1]

Dosyanız ektedir.

Sub sayfalara_aktar()
Dim s1 As Worksheet, sh As Worksheet, sat As Long, i As Long
Dim z As Object, isim As String
Set s1 = Sheets("muhasebe")
sat = s1.Cells(65536, "B").End(xlUp).Row
s1.Range("A1").AutoFilter
Set z = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
On Error Resume Next
For i = 2 To sat
    isim = s1.Cells(i, "B").Value & s1.Cells(i, "C").Value
    isim = UCase(Replace(Replace(isim, "ı", "I"), "i", "İ"))
    If Not z.exists(isim) Then
        z.Add (isim), Nothing
        For Each sh In Worksheets
            If UCase(Replace(Replace(sh.Name, "ı", "I"), "i", "İ")) = isim Then
                sh.Range("A1:F65536").ClearContents
                s1.Range("A1").AutoFilter field:=2, Criteria1:=s1.Cells(i, "B").Value
                s1.Range("A2").AutoFilter field:=3, Criteria1:=s1.Cells(i, "C").Value
                s1.Range("A1:F" & sat).CurrentRegion.Copy sh.Range("A1")
                s1.Range("A1").AutoFilter
                Exit For
            End If
        Next
    End If
Next i
Application.ScreenUpdating = True
MsgBox "Sayfalara aktarma başarı ile yapıldı." & _
vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
            
End Sub