Excelden Accesse Veri Alıp Gönderme

1 2 3 4 5 6 7 8 9 10 11
12/02/2021, 23:20

hayalibey

Hocam dosyaya bakma imkanınız oldu mu
13/02/2021, 00:18

berduş

accesse aktarmak için aşağıdaki kodu kullanmayı deneyebilirsiniz
yalnız daha önceden belirttiğim gibi isimle Access alan adı kurallarına uymalı
aslında hafta sonu ilgilenmeyi düşünüyordum ama maalesef 1 hafta kadar uygun olamayacağım
o nedenle biraz aceleye geldi
Dim strPath As String
Dim objAccess As Object

strPath = ThisWorkbook.Path & "\YILDIZ_VeriTabanı.accdb"

Set objAccess = CreateObject("Access.Application")
Call objAccess.OpenCurrentDatabase(strPath)
objAccess.Visible = True
'On Error Resume Next
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) Then
            SyfAdi = ListBox1.List(i)
            TblSay = objAccess.DCount("Name", "MSysObjects", "Name='" & SyfAdi & "' and type in (1,4,6)")
            If TblSay > 0 Then objAccess.DoCmd.DeleteObject acTable, SyfAdi
            If SyfVarMi(SyfAdi) = True Then objAccess.DoCmd.TransferSpreadsheet 0, 10, SyfAdi, ThisWorkbook.FullName, True, SyfAdi & "$"
        End If
    Next i
'    objAccess.DoCmd.Save
    objAccess.CloseCurrentDatabase
    objAccess.Quit
    MsgBox "aktarım tamam"
Modüle eklenecek fonksiyon
Function SyfVarMi(ByVal SyfAdiMtn As String) As Boolean
'i = 0
Dim ws As Worksheet
SyfVarMi = False
For Each ws In Worksheets
If ws.Name = SyfAdiMtn Then SyfVarMi = True
Next ws

End Function
13/02/2021, 13:39

hayalibey

(13/02/2021, 00:18)berduş yazdı: accesse aktarmak için aşağıdaki kodu kullanmayı deneyebilirsiniz
yalnız daha önceden belirttiğim gibi isimle Access alan adı kurallarına uymalı
aslında hafta sonu ilgilenmeyi düşünüyordum ama maalesef 1 hafta kadar uygun olamayacağım
o nedenle biraz aceleye geldi
Dim strPath As String
Dim objAccess As Object

strPath = ThisWorkbook.Path & "\YILDIZ_VeriTabanı.accdb"

Set objAccess = CreateObject("Access.Application")
Call objAccess.OpenCurrentDatabase(strPath)
objAccess.Visible = True
'On Error Resume Next
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) Then
            SyfAdi = ListBox1.List(i)
            TblSay = objAccess.DCount("Name", "MSysObjects", "Name='" & SyfAdi & "' and type in (1,4,6)")
            If TblSay > 0 Then objAccess.DoCmd.DeleteObject acTable, SyfAdi
            If SyfVarMi(SyfAdi) = True Then objAccess.DoCmd.TransferSpreadsheet 0, 10, SyfAdi, ThisWorkbook.FullName, True, SyfAdi & "$"
        End If
    Next i
'    objAccess.DoCmd.Save
    objAccess.CloseCurrentDatabase
    objAccess.Quit
    MsgBox "aktarım tamam"

Hocam Merhaba

Emek harcadığınız için çok teşekkür ederim . Ama kod aşağıdaki hatayı verdi ve hiç çalışmadı

If SyfVarMi(SyfAdi) = True Then objAccess.DoCmd.TransferSpreadsheet 0, 10, SyfAdi, ThisWorkbook.FullName, True, SyfAdi & "$"
SyfVarMi kısmı sarıya boyanarak sub for function not defined  hatası veriyor
13/02/2021, 15:03

berduş

hangi sayfayı eklemeye çalıştığınızda bu hatayı verdi?
13/02/2021, 15:09

feraz

(13/02/2021, 15:03)berduş yazdı: hangi sayfayı eklemeye çalıştığınızda bu hatayı verdi?
Berduş hocam anladığım kadarıyla sayfaad için function yazmışınız lakin dosyaya eklenmemiş
13/02/2021, 15:43

berduş

kusura bakmayın aceleden eklemeyi unutmuşum, aşağıdaki fonksiyonu yeni bir modüle ekler misiniz?
Function SyfVarMi(ByVal SyfAdiMtn As String) As Boolean

Dim ws As Worksheet
SyfVarMi = False
For Each ws In Worksheets
    If ws.Name = SyfAdiMtn Then SyfVarMi = True
Next ws

End Function

aslında o kontrole bu aşamada gerek yok zaten sayfa yoksa listeye de eklenemeyeceği için tekrar kontrol etmek anlamsız
amacım accessten excele aktarırken bu denetimi yapmaktı ama işler maalesef aceleye geldiği için yeterince düzenleme yapamadım
aslında orada kod
If SyfVarMi(SyfAdi) = True Then objAccess.DoCmd.TransferSpreadsheet 0, 10, SyfAdi, ThisWorkbook.FullName, True, SyfAdi & "$"
yerine aşağıdaki şekilde de yazılabilirdi

objAccess.DoCmd.TransferSpreadsheet 0, 10, SyfAdi, ThisWorkbook.FullName, True, SyfAdi & "$"
1 2 3 4 5 6 7 8 9 10 11