• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Makro ile dosyalardan veritabanına bilgi aktarımı

  • Konbuyu başlatan Konbuyu başlatan arda41
  • Başlangıç tarihi Başlangıç tarihi
A

arda41

Altın Üye
Katılım
30 Mayıs 2010
Mesajlar
127
Excel Vers. ve Dili
Excel2010
Türkçe
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

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

  • Hata Mesaj_1.png
    Hata Mesaj_1.png
    103.5 KB · Görüntüleme: 6
  • Hata Mesaj_2.png
    Hata Mesaj_2.png
    79.4 KB · Görüntüleme: 5
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
 
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
 
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.
Geri
Üst