varolan sayfaya veri atarken eksik atıyor

[cemşir79]

Aşağıdaki kodla sayfa olmayınca verileri atmak 10 saniye sürmüyor, fakat varolan sayfalara veri aktarmak istediğim zaman hem iş uzun sürüyor hemde eksik bilgi atıyor.Kodda nasıl bir düzenleme yapılabilir

Sub Aktar()
Dim i As Long
Dim Sayfa As String
Set sg = Sheets("Rapor")
sg.Select
Application.ScreenUpdating = True
For i = 6 To [A65536].End(3).Row
If Cells(i, "F") <> "" Then

    Sayfa = Trim(Cells(i, "F"))
    
    If Not SayfaVarMi(Sayfa) Then
        Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = Sayfa
        sg.Select
        Range("A5:G5").Copy Sheets(Sayfa).[A5]
    End If
    
    Range("A" & i & ":G" & i).Copy Sheets(Sayfa).Range("A" & Sheets(Sayfa).[A65536].End(3).Row + 1)
   
    
Sheets(Sayfa).Columns("A:A").ColumnWidth = Columns("A:A").ColumnWidth
Sheets(Sayfa).Columns("B:B").ColumnWidth = Columns("B:B").ColumnWidth
Sheets(Sayfa).Columns("C:C").ColumnWidth = Columns("C:C").ColumnWidth
Sheets(Sayfa).Columns("D:D").ColumnWidth = Columns("D:D").ColumnWidth
Sheets(Sayfa).Columns("E:E").ColumnWidth = Columns("E:E").ColumnWidth
Sheets(Sayfa).Columns("F:F").ColumnWidth = Columns("F:F").ColumnWidth
Sheets(Sayfa).Columns("G:G").ColumnWidth = Columns("G:G").ColumnWidth
Sheets(Sayfa).Columns("H:H").ColumnWidth = Columns("H:H").ColumnWidth

Application.Calculation = xlAutomatic
Application.ScreenUpdating = False

End If
Next i

End Sub


Function SayfaVarMi(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarMi = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
End Function