Gif ekledim çalışıyor ve o dosyayı ekleyeyim bir deneyin.
Private Sub CommandButton1_Click()
Dim strPath As String
Dim objAccess As Object
Dim say As Integer
strPath = ThisWorkbook.Path & "\Test.accdb"
Set objAccess = CreateObject("Access.Application")
Call objAccess.OpenCurrentDatabase(strPath)
objAccess.Visible = True
For i = 0 To Me.ListBox1.ListCount - 1
If Me.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
say = say + 1
objAccess.DoCmd.DeleteObject acTable, SyfAdi
objAccess.DoCmd.TransferSpreadsheet 0, 10, SyfAdi, ThisWorkbook.FullName, True, SyfAdi & "$"
End If
End If
Next i
objAccess.CloseCurrentDatabase
objAccess.Quit
Set objAccess = Nothing
If say > 0 Then
MsgBox "aktarým tamam"
Else
MsgBox "Veri tabaninda secilen sayfalar bulunamadi...", vbCritical, "Hata"
End If
End Sub