referanslara Activex data Object 2 eklenmiştir
aslında Excel dosyası açılmadan da veri eklenebiliyor ama ilginç bir şekilde eklenen yeni veriler sarı olduğu için geçici olarak açmak zorunda kaldım
If TextBox1.Text = "" Then MsgBox ("Tarih Bilgisi Boş Olamaz"), vbCritical: Exit Sub
Dosya_Adı = ThisWorkbook.Path & "\SEVKİYAT TAKİBİ.xlsx"
sayfa_Adı = "LOJİSTİK"
Dim wb As Workbook
Application.ScreenUpdating = False
Set wb = Workbooks.Open(Dosya_Adı)
wb.Windows(1).Visible = False
Dim HdfSQL, KykSQL As String
Dim HdfRs As ADODB.Recordset
Dim HdfCn As ADODB.Connection
Dim KykRs As ADODB.Recordset
Dim KykCn As ADODB.Connection
HdfSQL = "SELECT * FROM [LOJİSTİK$];"
Set HdfRs = New ADODB.Recordset
Set HdfCn = New ADODB.Connection
HdfCn.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & Dosya_Adı & _
";extended properties=""excel 8.0;hdr=no"""
HdfCn.Open
HdfRs.Open HdfSQL, HdfCn, adOpenKeyset, adLockOptimistic
KykSQL = "SELECT * FROM [Rapor$A4:N] where [F11]=date();"
Set KykRs = New ADODB.Recordset
Set KykCn = New ADODB.Connection
KykCn.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & _
";extended properties=""excel 8.0;hdr=no"""
KykCn.Open
KykRs.Open KykSQL, KykCn, 3, 1
'
' Eğer Hiç Kayıt Yoksa
If KykRs.RecordCount = 0 Then
KykRs.Close
KykCn.Close
Set KykRs = Nothing
Set KykCn = Nothing
MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"
Exit Sub
End If
KykRs.MoveLast
KykRs.MoveFirst
Do While Not KykRs.EOF
HdfRs.AddNew
HdfRs(0) = KykRs(0)
HdfRs(1) = KykRs(1)
HdfRs(2) = KykRs(2)
HdfRs(3) = KykRs(3)
HdfRs(4) = KykRs(4)
HdfRs(5) = KykRs(5)
HdfRs(6) = KykRs(6)
HdfRs(7) = KykRs(7)
HdfRs(8) = KykRs(8)
HdfRs(9) = "NETLOG"
HdfRs(10) = KykRs(10)
HdfRs(11) = KykRs(11)
HdfRs.Update
KykRs.MoveNext
Loop
wb.Windows(1).Visible = True
wb.Save
wb.Close
Application.ScreenUpdating = True
HdfRs.Close
HdfCn.Close
Set HdfRs = Nothing
Set HdfCn = Nothing
KykRs.Close
KykCn.Close
Set KykRs = Nothing
Set KykCn = Nothing
