Makroyla veri aktarmak

[marlalı1]

arkadaşlar ekteki dosyayı incelermisiniz.sayfa1 deki verileri sayfa2 ye aktarmak istiyorum.sayfa 2 den tarihi seçince aktar butonuna tıkladığımda sayfa1 de bulunan o tarihteki veriler sayfa2 ye aktarsın.formülle bunu yaptım ama çok yer kapladı ve dosyayı çok ağır çalıştırıyor. bunu makroyla yapmak istiyorum.acaba nasıl yaparız.yardımcı olurmusunuz.

 

[marlalı1]

97-2003 formatı

dosyanın 97-2003 formatnı ekledim

 

[Orion1]

Dosyanız ekte.

Sub aktar()
Dim i As Long, k As Range, sut As Integer
Dim ilk As Date
Sheets("Sayfa2").Select
Application.ScreenUpdating = False
Range("B5:C65536").Clear
ilk = DateSerial(Year(Range("C1").Value), Month(Range("C1").Value), 1)
With Sheets("Sayfa1")
    For i = 5 To Cells(65536, "A").End(xlUp).Row
        Set k = .Range("B1:IV1").Find(Cells(i, "A").Value, , xlValues, xlWhole)
        If k Is Nothing Then
            GoTo atla
            Else
            sut = k.Column
        End If
        Set k = Nothing
        Set k = .Range("A2:A65536").Find(Cells(1, "C").Value, , xlValues, xlWhole)
        If Not k Is Nothing Then
            Cells(i, "B").Value = .Cells(k.Row, sut).Value
        End If
        .Range("A1").AutoFilter field:=1, Criteria1:=">=" & _
        CDbl(ilk), Operator:=xlAnd, Criteria2:="<=" & CDbl(CDate(Range("C1").Value))
        Cells(i, "C").Value = WorksheetFunction.Subtotal(9, .Range(.Cells(1, sut), .Cells(65536, sut)))
        .Range("A1").AutoFilter
atla:
    Next i
End With
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır", vbOKOnly + vbInformation, Application.UserName

End Sub

 

[marlalı1]

hocam çok sağol tam istediğim gibi oldu,