Hocam dosyaya bakma imkanınız oldu mu

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

hangi sayfayı eklemeye çalıştığınızda bu hatayı verdi?

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

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 & "$"