Makro ile dosyalardan veritabanına bilgi aktarımı

A

arda41

Altın Üye
Katılım
30 Mayıs 2010
Mesajlar
127
Excel Vers. ve Dili
Excel2010
Türkçe
Altın Üyelik Bitiş Tarihi
28-12-2030
Merhabalar,

Ekte yapmak istediğim uygulamayı dosya içinde anlatmaya çalıştığım çalışma ve veritabanı dosyaları yer almaktadır. Yardımcı olabilecek siz değerli forum üyelerine şimdiden çok teşekkür ederim.

Saygılarımla
İyi çalışmalar
 

Ekli dosyalar

veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Kod: 
Sub aktarGuncelle()
    Dim fName$, con As Object, rs As Object, strSql

    fName = ThisWorkbook.Path & "\veritabanı.xlsx"
    If Dir(fName) = Empty Then
        MsgBox fName & " bulunamadı!"
        GoTo cikis
    End If

    Set con = CreateObject("ADODB.Connection")
    con.Provider = "Microsoft.ACE.OLEDB.12.0"

    con.Properties("Data Source") = fName
    con.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    con.Open

    If con.State <> 1 Then
        MsgBox "ADO bağlantısı kurulamadı."
        GoTo cikis
    End If

    If Range("A2").Value <> "" Then
        Set rs = CreateObject("ADODB.Recordset")
        strSql = "SELECT * FROM [Sayfa1$] WHERE KOD=" & Range("A2").Value
        rs.Open strSql, con, 2, 3

        If (rs.EOF Or rs.bof) Then
            rs.Close
            strSql = "SELECT * FROM [Sayfa1$]"
            rs.Open strSql, con, 2, 3
            rs.addnew
            rs.Fields("Kod") = Range("A2").Value
        End If

        rs.Fields("Veri1") = Range("B2").Value
        rs.Fields("Veri2") = Range("C2").Value
        rs.Fields("Veri3") = Range("D2").Value
        rs.Update
        rs.Close

        'Range("H:K").ClearContents
        'strSql = "SELECT * FROM [Sayfa1$]"
        'rs.Open strSql, con, 2, 3
        'Range("H1").CopyFromRecordset rs
        'rs.Close

        Set rs = Nothing
    End If

cikis:
    con.Close
    Set con = Nothing
End Sub
 
A

arda41

Altın Üye
Katılım
30 Mayıs 2010
Mesajlar
127
Excel Vers. ve Dili
Excel2010
Türkçe
Altın Üyelik Bitiş Tarihi
28-12-2030
veyselemre' Alıntı:
Kod: 
Sub aktarGuncelle()
    Dim fName$, con As Object, rs As Object, strSql

    fName = ThisWorkbook.Path & "\veritabanı.xlsx"
    If Dir(fName) = Empty Then
        MsgBox fName & " bulunamadı!"
        GoTo cikis
    End If

    Set con = CreateObject("ADODB.Connection")
    con.Provider = "Microsoft.ACE.OLEDB.12.0"

    con.Properties("Data Source") = fName
    con.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    con.Open

    If con.State <> 1 Then
        MsgBox "ADO bağlantısı kurulamadı."
        GoTo cikis
    End If

    If Range("A2").Value <> "" Then
        Set rs = CreateObject("ADODB.Recordset")
        strSql = "SELECT * FROM [Sayfa1$] WHERE KOD=" & Range("A2").Value
        rs.Open strSql, con, 2, 3

        If (rs.EOF Or rs.bof) Then
            rs.Close
            strSql = "SELECT * FROM [Sayfa1$]"
            rs.Open strSql, con, 2, 3
            rs.addnew
            rs.Fields("Kod") = Range("A2").Value
        End If

        rs.Fields("Veri1") = Range("B2").Value
        rs.Fields("Veri2") = Range("C2").Value
        rs.Fields("Veri3") = Range("D2").Value
        rs.Update
        rs.Close

        'Range("H:K").ClearContents
        'strSql = "SELECT * FROM [Sayfa1$]"
        'rs.Open strSql, con, 2, 3
        'Range("H1").CopyFromRecordset rs
        'rs.Close

        Set rs = Nothing
    End If

cikis:
    con.Close
    Set con = Nothing
End Sub
Genişletmek için tıkla ...
veyselemre' Alıntı:
Kod: 
Sub aktarGuncelle()
    Dim fName$, con As Object, rs As Object, strSql

    fName = ThisWorkbook.Path & "\veritabanı.xlsx"
    If Dir(fName) = Empty Then
        MsgBox fName & " bulunamadı!"
        GoTo cikis
    End If

    Set con = CreateObject("ADODB.Connection")
    con.Provider = "Microsoft.ACE.OLEDB.12.0"

    con.Properties("Data Source") = fName
    con.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    con.Open

    If con.State <> 1 Then
        MsgBox "ADO bağlantısı kurulamadı."
        GoTo cikis
    End If

    If Range("A2").Value <> "" Then
        Set rs = CreateObject("ADODB.Recordset")
        strSql = "SELECT * FROM [Sayfa1$] WHERE KOD=" & Range("A2").Value
        rs.Open strSql, con, 2, 3

        If (rs.EOF Or rs.bof) Then
            rs.Close
            strSql = "SELECT * FROM [Sayfa1$]"
            rs.Open strSql, con, 2, 3
            rs.addnew
            rs.Fields("Kod") = Range("A2").Value
        End If

        rs.Fields("Veri1") = Range("B2").Value
        rs.Fields("Veri2") = Range("C2").Value
        rs.Fields("Veri3") = Range("D2").Value
        rs.Update
        rs.Close

        'Range("H:K").ClearContents
        'strSql = "SELECT * FROM [Sayfa1$]"
        'rs.Open strSql, con, 2, 3
        'Range("H1").CopyFromRecordset rs
        'rs.Close

        Set rs = Nothing
    End If

cikis:
    con.Close
    Set con = Nothing
End Sub
Genişletmek için tıkla ...
Sayın VeyselEmre,

Başta emeğiniz ve dönüşünüz için çok teşekkürler.

Yazdığınız kodu çalışma dosyasına ekleyip veritabanının veriyolunu tanıttım. Ancak ekteki görselde görülen hatayı vermektedir. Nedeni ne olabilir acaba? Çok teşekkürler.

Saygılarımla
 

Ekli dosyalar

A

arda41

Altın Üye
Katılım
30 Mayıs 2010
Mesajlar
127
Excel Vers. ve Dili
Excel2010
Türkçe
Altın Üyelik Bitiş Tarihi
28-12-2030
veyselemre' Alıntı:
Kod: 
Sub aktarGuncelle()
    Dim fName$, con As Object, rs As Object, strSql

    fName = ThisWorkbook.Path & "\veritabanı.xlsx"
    If Dir(fName) = Empty Then
        MsgBox fName & " bulunamadı!"
        GoTo cikis
    End If

    Set con = CreateObject("ADODB.Connection")
    con.Provider = "Microsoft.ACE.OLEDB.12.0"

    con.Properties("Data Source") = fName
    con.Properties("Extended Properties") = "Excel 12.0; HDR=Yes"
    con.Open

    If con.State <> 1 Then
        MsgBox "ADO bağlantısı kurulamadı."
        GoTo cikis
    End If

    If Range("A2").Value <> "" Then
        Set rs = CreateObject("ADODB.Recordset")
        strSql = "SELECT * FROM [Sayfa1$] WHERE KOD=" & Range("A2").Value
        rs.Open strSql, con, 2, 3

        If (rs.EOF Or rs.bof) Then
            rs.Close
            strSql = "SELECT * FROM [Sayfa1$]"
            rs.Open strSql, con, 2, 3
            rs.addnew
            rs.Fields("Kod") = Range("A2").Value
        End If

        rs.Fields("Veri1") = Range("B2").Value
        rs.Fields("Veri2") = Range("C2").Value
        rs.Fields("Veri3") = Range("D2").Value
        rs.Update
        rs.Close

        'Range("H:K").ClearContents
        'strSql = "SELECT * FROM [Sayfa1$]"
        'rs.Open strSql, con, 2, 3
        'Range("H1").CopyFromRecordset rs
        'rs.Close

        Set rs = Nothing
    End If

cikis:
    con.Close
    Set con = Nothing
End Sub
Genişletmek için tıkla ...
Sayın VeyselEmre,

Kusura bakmayın az önce fark ettim. Veritabanının yolunu tanıtmadan kodu yazdığınız şekilde çalışma dosyası ve veritabanı aynı klasörde olursa kod çalışıyor sorun yok ama çalışma dosyası ve veritabanı aynı klasörde olmayacak. Çalışma dosyaları farklı klasörlerde olacak. Çalışma dosyasını farklı klasöre taşıyıp veritabanı mevcut veriyolunu koda eklediğim zamanda aynı hatayı veriyor maalesef.

Teşekkürler.
Saygılarımla
 
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
fName = ThisWorkbook.Path & "\veritabanı.xlsx"
Tam dosya yolu tanımladığınız için kırmızı kısmı silin, tırnak içine tam dosya yolunu yazın
 
A

arda41

Altın Üye
Katılım
30 Mayıs 2010
Mesajlar
127
Excel Vers. ve Dili
Excel2010
Türkçe
Altın Üyelik Bitiş Tarihi
28-12-2030
veyselemre' Alıntı:
fName = ThisWorkbook.Path & "\veritabanı.xlsx"
Tam dosya yolu tanımladığınız için kırmızı kısmı silin, tırnak içine tam dosya yolunu yazın
Genişletmek için tıkla ...
Çok teşekkürler. elinize emeğinize sağlık. Saygılarımla
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst