Kapalı dosyaya veri kopyalama

[EmrExcel16]

Merhaba arkadaşlar açık olan dosyamdan kapalı olan dosyaya, dosyayı açmadan veri göndermek istiyorum bunu aşağıdaki kodla yapıyorum fakat bu kod dosyayı açıp işlemi yapıp kaydedip kapatıyor buda işlemin uzamasına neden oluyor ve kod da yavaşlıyor ben bunu daha hızlı nasıl yapabilirim yardımlarınız için teşekkür ederim

Option Explicit
Sub veri_gönder()
Dim XCL As Application, KTP As Workbook, ÇLŞ As Variant
Dim S1 As Worksheet, S2 As Worksheet, YL As String
Dim STR As Long, STR1 As Long, STR2 As Long
Application.ScreenUpdating = False
Set XCL = CreateObject("Excel.Application")
XCL.Visible = False
Set S1 = Sheets("ÇIKIŞ")
STR = S1.Range("A" & Rows.Count).End(xlUp).Row
Set KTP = XCL.Workbooks.Open(ThisWorkbook.Path & "\Kitap1.xls")
ÇLŞ = ActiveCell.Address
Set S2 = KTP.Sheets("Çıkış")
STR1 = S2.Range("B" & Rows.Count).End(xlUp).Row + 1
S1.Range("A4:A" & STR).Copy
S2.Range("B" & STR1).PasteSpecial (xlPasteValuesAndNumberFormats)
S1.Range("B4:B" & STR).Copy
S2.Range("C" & STR1).PasteSpecial (xlPasteValuesAndNumberFormats)
S1.Range("C4:C" & STR).Copy
S2.Range("D" & STR1).PasteSpecial (xlPasteValuesAndNumberFormats)
Application.CutCopyMode = False
STR2 = S2.Range("B" & Rows.Count).End(xlUp).Row
S2.Range("E" & STR1 & ":E" & STR2) = S1.Range("E5")
S2.Range("F" & STR1 & ":F" & STR2) = S1.Range("D5")
S2.Range("G" & STR1 & ":G" & STR2) = " " & Application.UserName
S2.Range("A2:A" & STR2).DataSeries rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
S2.Range(ÇLŞ).Select
KTP.Save: KTP.Close: XCL.Quit
Application.ScreenUpdating = True
End Sub

Açık olan dosya TABLO dosyasıdır

 

[EmrExcel16]

Konu hakkında yardımcı olabilecek arkadaşlardan yardımlarını rica ederim

 

[Orion1]

Dosyanız ektedir.

Sub aktar59ado()
Dim conn As Object, rs As Object
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
        "\Kitap1.xls;extended properties=""excel 8.0;hdr=no;imex=0"";"
Set rs = conn.Execute("select max(F1) from [Çıkış$A2:A65536]")
'Set KS = Baglan.Execute("SELECT Max(SIRA) FROM Tablo2")
If IsNull(rs(0).Value) Then
    satir = 1
Else
    satir = rs(0).Value + 1
End If
rs.Close
rs.Open "select * from [Çıkış$A2:G65536];", conn, 1, 3
sat = Cells(Rows.Count, "B").End(xlUp).Row
For i = 4 To sat
    rs.addnew
    rs(0).Value = satir
    rs(1).Value = Cells(i, "A").Value
    rs(2).Value = Cells(i, "B").Value
    rs(3).Value = Cells(i, "C").Value
    rs(4).Value = Cells(5, "E").Value
    rs(5).Value = Cells(5, "D").Value
    rs(6).Value = Application.UserName
    rs.Update
    satir = satir + 1
Next
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing

MsgBox "Veriler Kitap1 dosyasına aktarıldı." & vbLf & _
        "evrengizlen@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[EmrExcel16]

Evren Hocam yardımınız için teşekkür ederim sağolun fakat
A sutununa sıra numarasını ve G sutununa username yazdırmıyor bu mümkün değilmi bilğilendirmenizi rica ederim
İyi çalışmalar..

 

[Orion1]

Evren Hocam yardımınız için teşekkür ederim sağolun fakat
A sutununa sıra numarasını ve G sutununa username yazdırmıyor bu mümkün değilmi bilğilendirmenizi rica ederim
İyi çalışmalar..

Dosyayı 3 nolu mesajda güncelledim.

 

[EmrExcel16]

Evren hocam teşekkür ederim sağolun

 

[Orion1]

Yolladığım dosyada ve kodda bir aksaklık vardı.
Kitap1 de Hiç veri yoksa verileri atamıyordu.
Bu durumu şimdi düzellttim.
Ancak buradada 2nci satıra(Kitap1 de) 0 (sıfır ) girmeniz gerekiyor.
Bu durumnda kitap1 i excel olarak değilde access (mdb) dosyası olarak kullanmanızı tavsiye ederim.Yani veri tabanınız access dosyası olsun.