Excel创建acc数据库的几个方法ZT_清风客

1-- Sub excel创建access数据库()
Dim myDatabase As DAO.Database     '定义数据库变量
Dim myDataTable As DAO.TableDef    '定义数据表变量
Dim myDatabaseName As String       '定义数据库名称
Dim myDataTableName As String      '定义数据表名称
myDatabaseName = ThisWorkbook.Path & "\小爪.mdb"
myDataTableName = "小爪成绩表"
'删除已经存在的数据库文件
On Error Resume Next
Kill myDatabaseName
On Error GoTo 0
'创建数据库文件
Set myDatabase = CreateDatabase(myDatabaseName, dbLangGeneral)
'创建数据表
Set myDataTable = myDatabase.CreateTableDef(myDataTableName)
'为数据表添加字段
With myDataTable
.Fields.Append .CreateField("学号", dbText, 8)
.Fields.Append .CreateField("姓名", dbText, 6)
.Fields.Append .CreateField("性别", dbText, 1)
.Fields.Append .CreateField("学科", dbText, 20)
.Fields.Append .CreateField("成绩", dbSingle)
End With
'将数据表添加到数据库对象中
myDatabase.TableDefs.Append myDataTable
Set myDatabase = Nothing    '释放变量
'弹出信息
MsgBox "创建数据库成功！" & vbCrLf _
& "数据库文件名为：" & myDatabaseName & vbCrLf _
& "数据表名称为：" & myDataTableName & vbCrLf _
& "保存位置：当前工作簿所在的文件夹。", _
vbokonluy + vbInformation, "创建数据库"
End Sub
2--Public Sub 创建的数据库名称()
Dim myData As String
Dim myDb As DAO.Database
'指定要创建的数据库名称
myData = ThisWorkbook.Path & "\NewData.mdb"
'判断数据库文件是否存在，如果存在，就删除它
If Dir(myData) <> "" Then Kill myData
'创建数据库
Set myDb = CreateDatabase(myData, dbLangChineseSimplified)
MsgBox "数据库创建成功！", vbInformation, "创建数据库"
'关闭数据库
myDb.Close
'释放变量
Set myDb = Nothing
End Sub
3--'创建数据库
Set myDb = CreateDatabase(myData, dbLangChineseSimplified & ";pwd=H1X2L3")
MsgBox "数据库创建成功！密码为：H1X2L3", vbInformation, "创建数据库"
4--Public Sub 创建数据库()
Dim myData As String, myTable As String
Dim myDb As DAO.Database
Dim myTbl As DAO.TableDef
Dim myIndex As DAO.Index
myData = ThisWorkbook.Path & "\职工信息.mdb"    '指定要创建的数据库名称
myTable = "基本资料"    '指定要创建的数据表名称
If Dir(myData) <> "" Then Kill myData    '判断数据库文件是否存在，如果存在，就删除它
Set myDb = CreateDatabase(myData, dbLangChineseSimplified)    '创建数据库
Set myTbl = myDb.CreateTableDef(myTable)    '创建数据表
Set myIndex = myTbl.CreateIndex("编号主键")    '创建索引
'为创建的数据表添加各个字段
With myTbl
.Fields.Append .CreateField("编号", dbText, 10)
.Fields.Append .CreateField("姓名", dbText, 6)
.Fields.Append .CreateField("性别", dbText, 1)
.Fields.Append .CreateField("部门", dbText, 10)
.Fields.Append .CreateField("出生日期", dbDate)
.Fields.Append .CreateField("基本工资", dbSingle)
.Fields.Append .CreateField("备注", dbText, 50)
'设置字段是否为必填字段
.Fields("编号").Required = True
.Fields("姓名").Required = True
.Fields("性别").Required = True
.Fields("出生日期").Required = True
.Fields("基本工资").Required = False
.Fields("备注").Required = False
'设置字段是否允许零长度的空字符串
.Fields("编号").AllowZeroLength = False
.Fields("姓名").AllowZeroLength = False
.Fields("性别").AllowZeroLength = False
.Fields("出生日期").AllowZeroLength = False
.Fields("基本工资").AllowZeroLength = False
.Fields("备注").AllowZeroLength = False
'创建主键索引
myIndex.Fields.Append myIndex.CreateField("编号")
.Indexes.Append myIndex       '将索引添加到索引集合中
'设置索引为主键,并且不允许重复
.Indexes("编号主键").Primary = True
.Indexes("编号主键").Unique = True
End With
myDb.TableDefs.Append myTbl    '将创建的数据表添加到数据库的TableDefs集合中
myDb.Close    '关闭数据库，并'释放变量
Set myDb = Nothing
Set myTbl = Nothing
'弹出信息
MsgBox "创建数据库成功！" & vbCrLf & "数据库文件名为：" & myData & vbCrLf _
& "数据表名称为：" & myTable & vbCrLf _
& "保存位置：" & ThisWorkbook.Path, vbInformation, "创建数据库"
End Sub
5--Public Sub 根据工作表创建数据库()
Dim myDb As DAO.Database
Dim myTable As DAO.TableDef
Dim myIndex As DAO.Index
Dim ws As Worksheet
Dim i As Long
Dim myData As String
'判断工作表是否存在
On Error Resume Next
Set ws = Worksheets("数据表设计")
On Error GoTo 0
If ws Is Nothing Then
MsgBox "没有数据表资料存在！", vbCritical, "警告"
Exit Sub
End If
ws.Activate
myData = ThisWorkbook.Path & "\" & Range("B1").Value & ".mdb"
'删除已经存在的数据库
If Dir(myData) <> "" Then Kill myData
'创建新数据库
Set myDb = CreateDatabase(myData, dbLangChineseSimplified)
'创建数据表
Set myTable = myDb.CreateTableDef(Range("B2").Value)
'创建索引
Set myIndex = myTable.CreateIndex("PrimaryKey")
myIndex.Primary = True
'开始为数据表添加字段
For i = 5 To Range("A65536").End(xlUp).Row
With myTable
.Fields.Append .CreateField(Cells(i, 1).Value, _
GetConstNo(Cells(i, 2).Value), Cells(i, 3).Value)
If Cells(i, 2).Value = "dbText" Then
If Cells(i, 4).Value = "True" Then
.Fields(Cells(i, 1).Value).AllowZeroLength = True
End If
End If
If Cells(i, 5).Value = "True" Then
.Fields(Cells(i, 1).Value).Required = True
Else
.Fields(Cells(i, 1).Value).Required = False
End If
If Cells(i, 6).Value = "是" Then
myIndex.Fields.Append myIndex.CreateField(Cells(i, 1).Value)
End If
End With
Next i
'将索引添加到索引集合中
myTable.Indexes.Append myIndex
'将数据表添加到数据表集合中
myDb.TableDefs.Append myTable
'弹出信息
MsgBox "数据库创建成功！" & vbCrLf & vbCrLf _
& "数据库名称为：" & ws.Range("B1").Value & ".mdb" & vbCrLf _
& "数据表名称为：" & ws.Range("B2").Value & vbCrLf _
& "保存位置为：" & ThisWorkbook.Path, _
vbOKOnly + vbInformation, "创建数据库和数据表"
'关闭数据库联接，并释放变量
myDb.Close
Set ws = Nothing
Set myIndex = Nothing
Set myTable = Nothing
Set myDb = Nothing
End Sub
'连上面程序
Function GetConstNo(myStr As String) As Integer
Select Case myStr
Case "dbBoolean": GetConstNo = 1
Case "dbByte": GetConstNo = 2
Case "dbInteger": GetConstNo = 3
Case "dbLong": GetConstNo = 4
Case "dbCurrency": GetConstNo = 5
Case "dbSingle": GetConstNo = 6
Case "dbDouble": GetConstNo = 7
Case "dbDate": GetConstNo = 8
Case "dbBinary": GetConstNo = 9
Case "dbText": GetConstNo = 10
Case "dbLongBinary": GetConstNo = 11
Case "dbMemo": GetConstNo = 12
Case "dbGUID": GetConstNo = 15
Case "dbBigInt": GetConstNo = 16
Case "dbVarBinary": GetConstNo = 17
Case "dbChar": GetConstNo = 18
Case "dbNumeric": GetConstNo = 19
Case "dbDecimal": GetConstNo = 20
Case "dbFloat": GetConstNo = 21
Case "dbTime": GetConstNo = 22
Case "dbTimeStamp": GetConstNo = 23
Case Else: GetConstNo = -1
End Select
End Function
**********************************************************************
B \ 在excel打开指定的acc表
Sub 在excel打开指定的acc表()
Dim myaccess As Access.Application
Dim myDatabaseName As String       '定义数据库名称
Dim myDataTableName As String      '定义数据表名称
'设置要打开的数据库名称（包括完整路径）
myDatabaseName = ThisWorkbook.Path & "\小爪.mdb"
'设置要打开的数据表名称
myDataTableName = "小爪成绩表"
'设置数据库变量
Set myaccess = GetObject(myDatabaseName)
'使打开的数据库可见
myaccess.Visible = True
'打开指定的数据表
myaccess.DoCmd.OpenTable myDataTableName
'最大化数据表窗口
myaccess.DoCmd.Maximize
'释放变量
Set myaccess = Nothing
End Sub
*****************************************************************
C\   Sub Excel用msgbox读取Access()
Dim mydata As String, mytable As String, n As Integer
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
mydata = ThisWorkbook.Path & "\客户管理.mdb"
mytable = "客户资料"
Set cnn = New ADODB.Connection
With cnn
.Provider = "microsoft.jet.oledb.4.0"
.Open mydata
End With
Set rs = New ADODB.Recordset
rs.Open mytable, cnn, adOpenKeyset, adLockOptimistic
n = rs.RecordCount
MsgBox "与数据库 " & mydata & "连接成功！" & vbCrLf & vbCrLf _
& "在数据库的" & mytable & "表中共有 " & n & " 条记录。", _
vbInformation, "连接数据库"
For i = 1 To n
MsgBox "编号为：" & rs.Fields("客户编号") & "的客户信息：" _
& vbCrLf & vbCrLf _
& "客户名称：" & rs.Fields("客户名称") & vbCrLf _
& "客户地址：" & rs.Fields("通讯地址") & vbCrLf _
& "邮政编码：" & rs.Fields("邮政编码") & vbCrLf _
& "联系电话：" & rs.Fields("联系电话"), _
vbInformation, "客户信息"
rs.MoveNext
Next i
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End Sub
*******************************************************
D\   Sub Excel用单元格记录Access表内容方法A（）
Dim myrow As Integer, mycol As Integer
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim mydata As String, mytable As String
Dim mysheet As Worksheet
mydata = ThisWorkbook.Path & "\客户管理.mdb"
mytable = "客户资料"
'建立与数据库的廉洁
Set cnn = New ADODB.Connection
With cnn
.Provider = "microsoft.jet.oledb.4.0;"
.Open mydata
End With
'查询数据表
Set rs = New ADODB.Recordset
rs.Open mytable, cnn, adOpenKeyset, adLockOptimistic
Set mysheet = ThisWorkbook.Sheets(1)
mysheet.Cells.ClearContents
'复制字段名
For mycol = 1 To rs.Fields.Count
mysheet.Cells(1, mycol) = rs.Fields(mycol - 1).Name
Next mycol
'复制记录数据
mysheet.Range("A2").CopyFromRecordset rs
'自动调整工作表
mysheet.Cells.Columns.AutoFit
mysheet.Cells(1, 1).Select
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End Sub
**********************************************************
E\   Sub Excel窗体的textbox数值添加到指定ACC中()
Dim i As Integer
res = MsgBox("准备添加当前的记录到数据库中！真要添加吗？", vbYesNo + vbQuestion, "添加记录")
If res = vbNo Then Exit Sub
'检查各个项目是否为空值
If TextBoxIsEmpty(客户编号, "客户编号") = True Then Exit Sub
If TextBoxIsEmpty(客户名称, "客户名称") = True Then Exit Sub
If TextBoxIsEmpty(通讯地址, "通讯地址") = True Then Exit Sub
If TextBoxIsEmpty(邮政编码, "邮政编码") = True Then Exit Sub
If TextBoxIsEmpty(联系电话, "联系电话") = True Then Exit Sub
If TextBoxIsEmpty(传真号码, "传真号码") = True Then Exit Sub
If TextBoxIsEmpty(EMail, "e-mail") = True Then Exit Sub
If TextBoxIsEmpty(联系人姓名, "联系人姓名") = True Then Exit Sub
If TextBoxIsEmpty(联系人电话, "联系人电话") = True Then Exit Sub
If TextBoxIsEmpty(信用等级, "信用等级") = True Then Exit Sub
'检查输入的客户编号是否唯一
For i = 1 To rs.RecordCount
If rs.Fields("客户编号") = 客户编号.Value Then
MsgBox "数据库中已经存在了一个客户编号 " & 客户编号.Value _
& " ！请重新输入编号！", vbCritical, "警告"
客户编号.Value = ""
客户编号.SetFocus
Exit Sub
End If
Next i
'将窗体数据添加到数据表
rs.AddNew
rs.Fields("客户编号") = 客户编号.Value
rs.Fields("客户名称") = 客户名称.Value
rs.Fields("通讯地址") = 通讯地址.Value
rs.Fields("邮政编码") = 邮政编码.Value
rs.Fields("联系电话") = 联系电话.Value
rs.Fields("传真号码") = 传真号码.Value
rs.Fields("E-mail") = EMail.Value
rs.Fields("联系人姓名") = 联系人姓名.Value
rs.Fields("联系人电话") = 联系人电话.Value
rs.Fields("信用等级") = 信用等级.Value
rs.Update
显示条.Caption = "在数据库中共有 " & rs.RecordCount & " 条记录。"
End Sub
*********************************************************
F\ Sub Excel单元格数值添加到指定ACC中记录并更新()
Dim mydata As String
Dim TableExists As Boolean
Dim myaccess As Access.Application
Dim myCmd As ADODB.Command
Dim SQL As String
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim ws As Worksheet
Set ws = Sheet1
mydata = ThisWorkbook.Path & "\学生管理.mdb"
'判断是否有"学生管理.mdb"文件,如果没有,就创建它
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(mydata) = False Then
Application.StatusBar = "正在创建数据库......"
Set myaccess = CreateObject("Access.Application")
myaccess.NewCurrentDatabase mydata
myaccess.CloseCurrentDatabase
Set myaccess = Nothing
End If
'建立与数据库"学生管理.mdb"的连接
Application.StatusBar = "正在建立与数据库的连接......"
Set cnn = New ADODB.Connection
With cnn
.Provider = "microsoft.jet.oledb.4.0"
.Open mydata
End With
'判断是否有数据表"学生信息",如果没有.就创建它
TableExists = False
Set rs = cnn.OpenSchema(adSchemaTables)
Do Until rs.EOF
Application.StatusBar = "正在检查数据表......"
If LCase(rs!table_name) = LCase("学生信息") Then
TableExists = True
Exit Do
End If
rs.MoveNext
Loop
If TableExists = False Then
Application.StatusBar = "正在创建数据表......"
Set myCmd = New ADODB.Command
Set myCmd.ActiveConnection = cnn
myCmd.CommandText = "create table 学生信息 (学号 text(10),姓名 text(4)," _
& "性别 text(1),系别 text(20),班级 text(10),面貌 text(2)," _
& "出生日期 date,籍贯 text(10))"
myCmd.Execute , , adCmdText
Set myCmd = Nothing
End If
'删除数据表中原有的全部记录
Application.StatusBar = "正在删除原有的全部记录......"
SQL = "delete from 学生信息"
Set rs = New ADODB.Recordset
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
'向数据表中添加新记录
SQL = "select * from 学生信息"
Set rs = New ADODB.Recordset
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
For i = 2 To ws.Range("A65536").End(xlUp).Row
Application.StatusBar = "正在向数据库添加学生信息记录......"
rs.AddNew
rs.Fields("学号") = ws.Cells(i, 1)
rs.Fields("姓名") = ws.Cells(i, 2)
rs.Fields("性别") = ws.Cells(i, 3)
rs.Fields("系别") = ws.Cells(i, 4)
rs.Fields("班级") = ws.Cells(i, 5)
rs.Fields("面貌") = ws.Cells(i, 6)
rs.Fields("出生日期") = ws.Cells(i, 7)
rs.Fields("籍贯") = ws.Cells(i, 8)
rs.Update
Next i
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Application.StatusBar = False
End Sub
************************************************************
G\ Sub Excel用单元格记录Access表内容方法B()
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim mydata As String, mySQL As String
mydata = ThisWorkbook.Path & "\学生管理.mdb"
Set cnn = New ADODB.Connection
Set cnn = New ADODB.Connection
With cnn
.Provider = "microsoft.jet.oledb.4.0"
.Open mydata
End With
Set rs = New ADODB.Recordset
mySQL = "select * from 学生信息"
rs.Open mySQL, cnn, adOpenKeyset, adLockOptimistic
For iCols = 0 To rs.Fields.Count - 1
Sheet1.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
Next iCols
Sheet1.Cells(2, 1).CopyFromRecordset rs
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
End Sub
**************************************************
编后话：要想成为EXCEL高手，至少至少你要了解ACCESS与excel之间的桥
宗旨：熟悉熟练代码备以后查询代码之需。小爪只喜欢excel，e交友