Farklı kategorilerdeki verileri ayrı ayrı sheetlere aktarma

[istanbulcahan]

Farklı kategorilerdeki verileri ayrı ayrı sheetlere aktarma yapmak istiyorum.

Sayfa aktarma için kullandığım makro bu işlemi karşılamıyor.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
  If Target.Address = "$C$2" <> Empty Then aktarr
End Sub
Sub aktarr()
Set s1 = ThisWorkbook.Worksheets("data")
Set s2 = ThisWorkbook.Worksheets("giriş")
s2.Cells(3, 3) = s1.Cells(4, 17)
s2.Cells(4, 3) = s1.Cells(5, 17)
s2.Cells(5, 3) = s1.Cells(6, 17)
s2.Cells(6, 3) = s1.Cells(7, 17)
s2.Cells(7, 3) = s1.Cells(8, 17)
s2.Cells(8, 3) = s1.Cells(9, 17)
s2.Cells(9, 3) = s1.Cells(10, 17)

Set s2 = Nothing
MsgBox "Var olan ilk kayıt bilgileri alındı.", vbInformation
End Sub

Ama kodu çoğaltabilirsem yada başka bir yöntemle makrolu nasıl olabilir.