- Katılım
- 4 Mayıs 2007
- Mesajlar
- 3,597
- Excel Vers. ve Dili
- 2016 PRO TÜRKÇE-İNG. 64 BİT
Aşağıdaki kodu kullanabilirsiniz.
Kod:
Public strDB As String
Sub deneme_access2() 'access ile oluşturmak
Zaman = Timer
If Dir(CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Newdb.mdb") <> "" Then
Kill CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Newdb.mdb"
End If
Set con = VBA.CreateObject("adodb.Connection")
Set rs = VBA.CreateObject("adodb.Recordset")
Set fso = VBA.CreateObject("scripting.filesystemobject")
Dim dizi()
yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\DATA.xlsx"
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & ";extended properties=""Excel 12.0;hdr=yes"""
sorgu = "select * from[sayfa1$] "
rs.Open sorgu, con, 1, 3
deg = rs.getrows
syc = rs.RecordCount - 1
rs.Close
con.Close
'-----------------------------------------------------------------------------
Call NewAccessDatabase2
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strDB & ";Persist Security Info=False;"
sorgu = "select * from[deneme]"
rs.Open sorgu, con, 1, 3
For i = 0 To syc
rs.addnew
For s = 0 To rs.Fields.Count - 1
If deg(s, i) = "" Then deg(s, i) = Null
rs.Fields(s) = deg(s, i)
Next s
'rs.Update
Next i
rs.Update
'-----------------------------------------------------------------------------
Set rs = Nothing
Set con = Nothing
MsgBox "Dosya kopyalama işlemi tamamlandı." & Chr(10) _
& Format(Timer - Zaman, "0.00")
'MsgBox "İşlem tamamlandı."
End Sub
Sub NewAccessDatabase2()
' MsgBox Application.Version
Dim appAccess As Object
Dim dbs As Object, tdf As Object, fld As Variant
'Const DB_Text As Long = 17
'Const FldLen As Integer = 40
' Set con = VBA.CreateObject("adodb.Connection")
yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\DATA.xlsx"
Set daoDBEngine = CreateObject("DAO.DBEngine.120")
Set Db = daoDBEngine.OpenDatabase(yol, False, False, "Excel 8.0; HDR=yes; IMEX=0;")
' con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
' yol & ";extended properties=""Excel 12.0;hdr=yes"""
' Set rs = con.Execute("select * from[sayfa1$]")
Set rs = Db.OpenRecordset("select * from[sayfa1$]")
strDB = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Newdb.mdb"
Set appAccess = CreateObject("Access.Application")
appAccess.NewCurrentDatabase strDB
Set dbs = appAccess.CurrentDb
Set tdf = dbs.CreateTableDef("Deneme")
For Each baslik In rs.Fields
' Set fld = tdf.CreateField(baslik.Name, DB_Text, FldLen)
Set fld = tdf.CreateField(Replace(baslik.Name, ".", "_"), baslik.Type, baslik.Size)
tdf.Fields.Append fld
Next baslik
dbs.TableDefs.Append tdf
Set appAccess = Nothing
rs.Close
' con.Close
Db.Close
End Sub