建立AccessDB

Option Explicit

Private Sub CreateAccDB(ByVal MdbFileName As String) ' 建立 MDB
CreateObject("DAO.DBEngine.36").CreateDatabase _
MdbFileName, ";LANGID=0x0404;CP=950;COUNTRY=0"
End Sub


Private Sub Command1_Click()
Dim strMDBfile As String

strMDBfile = "C:\report\Test.mdb"
If Dir(strMDBfile) = "" Then CreateAccDB strMDBfile
If Dir(strMDBfile) <> "" Then MsgBox "建立完成"

CreateTable2 strMDBfile


End Sub

Sub CreateTable(strMDBfile As String)
Dim cn As ADODB.Connection
Set cn = CreateObject("ADODB.Connection")
Dim rs As ADODB.Recordset
Dim strSql As String
Dim Tbl As New Table
Dim Cat As ADOX.Catalog
Dim i As Integer
'Set Tbl = CreateObject("Table")
Set Cat = CreateObject("ADOX.Catalog")
With cn
.ConnectionString = "provider=sqloledb.1;persist security info=false;user id=sa;password=i513;initial catalog=apcb;data source=apcb08"
.Open
End With

strSql = "select * from K_HubMtl_Stocks"

Set rs = cn.Execute(strSql)

'Dim Tbl As New Table
'Dim Cat As New ADOX.Catalog

Cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strMDBfile & ";"
Tbl.Name = "MyTable"
For i = 0 To rs.Fields.Count - 1
Tbl.Columns.Append rs.Fields(i).Name, adVarWChar, 200
'Select Case rs.Fields(i).Type
' Case 2
' Tbl.Columns.Append rs.Fields(i).Name, adInteger
'Case 135
' Tbl.Columns.Append rs.Fields(i).Name, adDate
' Case 200
' Tbl.Columns.Append rs.Fields(i).Name, adVarChar, rs.Fields(i).DefinedSize
'Case 131
' Tbl.Columns.Append rs.Fields(i).Name, adNumeric, rs.Fields(i).DefinedSize

'End Select
Next i

Cat.Tables.Append Tbl

'塞資料


cn.Close
Set rs = Nothing
Set cn = Nothing
Set Tbl = Nothing
Set Cat = Nothing
End Sub

Sub CreateTable2(strMDBfile As String)
Dim cn As ADODB.Connection
Set cn = CreateObject("ADODB.Connection")

Dim rs As ADODB.Recordset

Dim strSql As String

With cn
.ConnectionString = "provider=sqloledb.1;persist security info=false;user id=sa;password=i513;initial catalog=apcb;data source=apcb08"
.Open
End With

With Adodc1
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strMDBfile & ";"
.RecordSource = "select * from MyTable"
End With


strSql = "select * from K_HubMtl_Stocks"

Set rs = cn.Execute(strSql)


'以下在用迴圈把資料add到acess裡面...
With rs
Do
Adodc1.Recordset.AddNew .Fields(0).Name, .Fields(0).Value
.MoveNext
While Not .EOF
End With

cn.Close
Set rs = Nothing
Set cn = Nothing
End Sub

如何用VBA or VB6將Excel資料匯出到Access 資料庫

Sub test()
Dim cn As Object
Dim rs As Object
Dim rs2 As Object
Dim i As Long
Dim iCount As Long
Set cn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
Set rs2 = CreateObject("adodb.recordset")
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\temp\db1.mdb;Persist Security Info=False"
rs.cursorlocation = 3
rs.Open "Select * From NewData", cn, 1, 3
For i = 1 To 65535
iCount = 0
If Range("A" & i).Text <> "" Then
If rs2.State = 1 Then rs2.Close
rs2.cursorlocation = 3
rs2.Open "Select * From NewData where [編號]=" & Range("A" & i).Text, cn, 0, 1 '數字要這樣
'rs2.Open "Select * From NewData where 編號='" & Range("A" & i).Text & "'", cn, 0, 1 '文字改這樣
iCount = rs2.RecordCount
End If
If iCount = 0 Then
rs.addnew
rs("編號") = IIf(Range("A" & i).Text = "", Null, Range("A" & i).Text)
End If
rs("名稱") = IIf(Range("B" & i).Text = "", Null, Range("B" & i).Text)
rs("數量") = IIf(Range("C" & i).Text = "", Null, Range("C" & i).Text)
If rs("編號") & "" = "" And rs("名稱") & "" = "" And rs("數量") & "" = "" Then
rs.cancelupdate
Exit For
End If
rs.Update
Next
End Sub