sayfalara aralıktaki bilgileri aktarma

[EXTRANET]

MERHABA

aşağıda makrı ile sayfalara dağıtım yapmaktayım ve sayfada olan bütün verileri aktarıyor.
veri sayfasının sadece a2 ile f10 aralığının aktarımını yapmam için nasıl bir makro yapılabilir


teşekürler


Sub sayfayaat_60()
Dim i As Long, sat As Long, sh As Worksheet
Dim sh2 As Worksheet
Set sh = Sheets("VERİ")
Application.ScreenUpdating = False
sh.Range("B1").AutoFilter
For i = 2 To Worksheets.Count
Set sh2 = Sheets(i)
sh.Range("B1").AutoFilter field:=1, Criteria1:=sh2.Name
If WorksheetFunction.Subtotal(103, sh.Range("B2:B" & sh.Rows.Count)) > 0 Then
sat = sh2.Cells(Rows.Count, "B").End(xlUp).Row + 1
sh.Range("B1").CurrentRegion.Offset(1, 0).Copy sh2.Range("B" & sat)
sh.Range("B1").AutoFilter
End If
Sheets("VERİ").Activate
Range("a2:F10").Select
Selection.ClearContents
Range("a2").Select
Application.ScreenUpdating = True

'Next


Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & "xxx"
End Sub

 

[EXTRANET]

Merhaba
arkadaşlar ekteki dosyada sayfalara dağıtım yapıyorum. Veri sayfasındaki sarı renkli sutun formüllü.dağıtım yaptığımda formüller siliniyor.formüllerin silinmemesi için.ilk 10 satırın dağıtımı yapılsa o da yeterli

çözüm lütfen başım çatladı son noktada tıkandım.