Ado İle Kapalı Dosyaya Şartlı Kayıt

kusura bakmayın biraz geç oldu
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