Skip to main content

AccessTr.neT M.


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

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

#7
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

Visual Basic Code
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

.rar excele Veri ekleme_hy.rar (Dosya Boyutu: 1,76 MB | İndirme Sayısı: 2)
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da