vba başka dosyaya veri aktarma

[kalibre101]

merhabalar aşagıdaki kodda verilerimi c veya d sürücüsü içindeki istasyon kayıt dosyasının içine boş olan son satıra atıyorum
ufak bir düzeltmede yardıma ihtiyacım var dahaönce atılan verilerin K stununa aktarıldı yazdırıyorum
aktarıldı yazan satırı atmasını istemiyorum kodda düzeltme yapabilirmisiniz acaba
işin özü önceden aktardığım verileri aktarmasın sadece yeni eklediğim veriyi aktarsın teşekkür ederim


Sub istasyon_Kaydı_2()
Dim say As Integer, a As Byte, sht As Worksheet, c As Integer, kyt As String, yol As String, yol2 As String, yol3 As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
yol2 = "D:\"
yol = "C:\İşletme Proğramı\İstasyon Kayıt\"
yol3 = "D:\İşletme Proğramı\İstasyon Kayıt\"
kyt = Sheets(57).[A1] & " " & "İstasyon Kayıt" & " .xlsx"
If Dir(yol2, vbDirectory) = "" Then
say = WorksheetFunction.CountA(ThisWorkbook.Sheets(116).Range("B:B"))
Set sht = Workbooks.Open(yol & kyt).Sheets(1)

For c = 3 To say
sht.Range("B1048576").End(xlUp).Offset(1, 0) = ThisWorkbook.Sheets(116).Range("B" & c)
sht.Range("A1048576").End(xlUp).Offset(1, 0) = sht.Range("A1048576").End(xlUp) + 1
For a = 1 To 8
sht.Range("B1048576").End(xlUp).Offset(0, a) = ThisWorkbook.Sheets(116).Range("B" & c).Offset(0, a)
ThisWorkbook.Sheets(116).Range("B" & c).Offset(0, 9) = "aktarıldı"
Next
Next

Else
say = WorksheetFunction.CountA(ThisWorkbook.Sheets(116).Range("B:B"))
Set sht = Workbooks.Open(yol3 & kyt).Sheets(1)
For c = 3 To say
sht.Range("B1048576").End(xlUp).Offset(1, 0) = ThisWorkbook.Sheets(116).Range("B" & c)
sht.Range("A1048576").End(xlUp).Offset(1, 0) = sht.Range("A1048576").End(xlUp) + 1
For a = 1 To 8
sht.Range("B1048576").End(xlUp).Offset(0, a) = ThisWorkbook.Sheets(116).Range("B" & c).Offset(0, a)
ThisWorkbook.Sheets(116).Range("B" & c).Offset(0, 9) = "aktarıldı"
Next
Next
End If
ActiveWorkbook.Save
ActiveWorkbook.Close
MsgBox "İstasyon Kayıtları Aktarıldı", vbApplicationModal, "NURETTİN KOÇAK"
Application.ScreenUpdating = True
say = 0: a = 0: Set sht = Nothing: c = 0: kyt = "": yol = "": yol2 = "": yol3 = ""
End Sub