在EXCEL中操作ACCESS库

silk1108 · 发表于 2010-9-1 14:14

一直想学习数据库知识，谢谢了

wach · 发表于 2010-9-1 17:58

谢谢楼主的分享!但我下载了前几个表(创建数据库,创建数据表等)全是空的EXCEL表没有宏没控件之类!

zez · 发表于 2010-9-1 19:17

原帖由 wach 于 2010-9-1 17:58 发表
谢谢楼主的分享!但我下载了前几个表(创建数据库,创建数据表等)全是空的EXCEL表没有宏没控件之类!

创建数据库及数据表.xls中的代码:
Public Sub 创建数据库及数据表方法1()
Dim myDb As DAO.Database
Dim myTbl As DAO.TableDef
Dim myData As String
Dim myTable As String
myData = ThisWorkbook.Path & "\学生成绩管理.mdb"
myTable = "期末成绩"
On Error Resume Next
Kill myData
On Error GoTo 0
Set myDb = CreateDatabase(myData, dbLangChineseSimplified)
Set myTbl = myDb.CreateTableDef(myTable)
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("数学", dbSingle)
      .Fields.Append .CreateField("语文", dbSingle)
      .Fields.Append .CreateField("物理", dbSingle)
      .Fields.Append .CreateField("化学", dbSingle)
      .Fields.Append .CreateField("英语", dbSingle)
      .Fields.Append .CreateField("总分", dbSingle)
End With
myDb.TableDefs.Append myTbl
myDb.Close
Set myDb = Nothing
Set myTbl = Nothing
MsgBox "创建数据库成功！" & vbCrLf _
      & "数据库文件名为：" & myData & vbCrLf _
      & "数据表名称为：" & myTable & vbCrLf _
      & "保存位置：" & ThisWorkbook.Path, _
      vbOKOnly + vbInformation, "创建数据库"
End Sub

Public Sub 创建数据库及数据表方法2()
Dim myCat As New ADOX.Catalog
Dim myTbl As New Table
Dim myData As String
Dim myTable As String
myData = ThisWorkbook.Path & "\学生成绩管理.mdb"
myTable = "期末成绩"
On Error Resume Next
Kill myData
On Error GoTo 0
myCat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & myData
With myTbl
      .Name = myTable
      .Columns.Append "学号", adVarWChar, 10
      .Columns.Append "姓名", adVarWChar, 6
      .Columns.Append "性别", adVarWChar, 1
      .Columns.Append "班级", adVarWChar, 10
      .Columns.Append "数学", adSingle
      .Columns.Append "语文", adSingle
      .Columns.Append "物理", adSingle
      .Columns.Append "化学", adSingle
      .Columns.Append "英语", adSingle
      .Columns.Append "总分", adSingle
End With
myCat.Tables.Append myTbl
Set myCat = Nothing
Set myTbl = Nothing
MsgBox "创建数据库成功！" & vbCrLf _
      & "数据库文件名为：" & myData & vbCrLf _
      & "数据表名称为：" & myTable & vbCrLf _
      & "保存位置：" & ThisWorkbook.Path, _
      vbOKOnly + vbInformation, "创建数据库"
End Sub

Public Sub 创建数据库及数据表方法3()
Dim myCat As New ADOX.Catalog
Dim myCmd As New ADODB.Command
Dim myData As String
Dim myTable As String
Dim SQL As String
myData = ThisWorkbook.Path & "\学生成绩管理.mdb"
myTable = "期末成绩"
On Error Resume Next
Kill myData
On Error GoTo 0
myCat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & myData
Set myCmd.ActiveConnection = myCat.ActiveConnection
SQL = "CREATE TABLE " & myTable _
      & "(学号 text(10),姓名 text(6),性别 text(1),班级 text(10)," _
      & "数学 Single,语文 Single,物理 Single,化学 Single," _
      & "英语 Single,总分 Single)"
With myCmd
      .CommandText = SQL
      .Execute , , adCmdText
End With
Set myCat = Nothing
Set myCmd = Nothing
MsgBox "创建数据库成功！" & vbCrLf _
      & "数据库文件名为：" & myData & vbCrLf _
      & "数据表名称为：" & myTable & vbCrLf _
      & "保存位置：" & ThisWorkbook.Path, _
      vbOKOnly + vbInformation, "创建数据库"
End Sub

zez · 发表于 2010-9-1 19:19

原帖由 wach 于 2010-9-1 17:58 发表
谢谢楼主的分享!但我下载了前几个表(创建数据库,创建数据表等)全是空的EXCEL表没有宏没控件之类!

7楼附件的代码:
Public Sub 在已有的数据库中创建数据表方法1()
Dim myDb As DAO.Database
Dim myTbl As DAO.TableDef
Dim myData As String
Dim myTable As String
myData = ThisWorkbook.Path & "\学生成绩管理.mdb"
myTable = "期末成绩"
Set myDb = OpenDatabase(myData)
myDb.TableDefs.Delete myTable
Set myTbl = myDb.CreateTableDef(myTable)
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("数学", dbSingle)
      .Fields.Append .CreateField("语文", dbSingle)
      .Fields.Append .CreateField("物理", dbSingle)
      .Fields.Append .CreateField("化学", dbSingle)
      .Fields.Append .CreateField("英语", dbSingle)
      .Fields.Append .CreateField("总分", dbSingle)
End With
myDb.TableDefs.Append myTbl
myDb.Close
Set myDb = Nothing
Set myTbl = Nothing
MsgBox "数据表<" & myTable & ">创建成功！", _
      vbOKOnly + vbInformation, "创建数据表"
End Sub

Public Sub 在已有的数据库中创建数据表方法2()
Dim myCat As New ADOX.Catalog
Dim myTbl As New Table
Dim myData As String
Dim myTable As String
myData = ThisWorkbook.Path & "\学生成绩管理.mdb"
myTable = "期末成绩"
myCat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" _
      & "Data Source=" & myData
myCat.Tables.Delete myTable
With myTbl
      .Name = myTable
      .Columns.Append "学号", adVarWChar, 10
      .Columns.Append "姓名", adVarWChar, 6
      .Columns.Append "性别", adVarWChar, 1
      .Columns.Append "班级", adVarWChar, 10
      .Columns.Append "数学", adSingle
      .Columns.Append "语文", adSingle
      .Columns.Append "物理", adSingle
      .Columns.Append "化学", adSingle
      .Columns.Append "英语", adSingle
      .Columns.Append "总分", adSingle
End With
myCat.Tables.Append myTbl
Set myCat = Nothing
Set myTbl = Nothing
MsgBox "数据表<" & myTable & ">创建成功！", _
      vbOKOnly + vbInformation, "创建数据表"
End Sub

Public Sub 在已有的数据库中创建数据表方法3()
Dim myCat As New ADOX.Catalog
Dim myCmd As New ADODB.Command
Dim myData As String
Dim myTable As String
Dim SQL As String
myData = ThisWorkbook.Path & "\学生成绩管理.mdb"
myTable = "期末成绩"
myCat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" _
      & "Data Source=" & myData
myCat.Tables.Delete myTable
Set myCmd.ActiveConnection = myCat.ActiveConnection
SQL = "CREATE TABLE " & myTable _
      & "(学号 text(10),姓名 text(6),性别 text(1),班级 text(10)," _
      & "数学 Single,语文 Single,物理 Single,化学 Single," _
      & "英语 Single,总分 Single)"
With myCmd
      .CommandText = SQL
      .Execute , , adCmdText
End With
Set myCat = Nothing
Set myCmd = Nothing
MsgBox "数据表<" & myTable & ">创建成功！", _
      vbOKOnly + vbInformation, "创建数据表"
End Sub

Public Sub 在已有的数据库中创建数据表方法4()
Dim cnn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim myData As String
Dim myTable As String
Dim SQL As String
myData = ThisWorkbook.Path & "\学生成绩管理.mdb"
myTable = "期末成绩"
With cnn
      .Provider = "Microsoft.Jet.OLEDB.4.0"
      .Open myData
End With
SQL = "drop table " & myTable
Set rs = cnn.Execute(SQL)
SQL = "CREATE TABLE " & myTable _
      & "(学号 text(10),姓名 text(6),性别 text(1),班级 text(10)," _
      & "数学 Single,语文 Single,物理 Single,化学 Single," _
      & "英语 Single,总分 Single)"
Set rs = cnn.Execute(SQL)
cnn.Close
Set rs = Nothing
Set cnn = Nothing
MsgBox "数据表<" & myTable & ">创建成功！", vbInformation, "创建数据表"
End Sub

zez · 发表于 2010-9-1 19:23

原帖由 wach 于 2010-9-1 17:58 发表
谢谢楼主的分享!但我下载了前几个表(创建数据库,创建数据表等)全是空的EXCEL表没有宏没控件之类!

8楼利用工作表数据创建数据表方法1.xls的代码:
Public Sub 利用工作表数据创建数据表方法1()
Dim myCat As New ADOX.Catalog
Dim myTable As New ADOX.Table
Dim myColumn As ADOX.Column
Dim myIdx As New ADOX.Index
Dim ws As Worksheet
Dim i As Long
Dim myData As String
myData = ThisWorkbook.Path & "\学生成绩管理.mdb"
On Error Resume Next
Set ws = Worksheets("数据表设计")
On Error GoTo 0
If ws Is Nothing Then
      MsgBox "没有数据表资料存在！", vbCritical, "警告"
      Exit Sub
End If
ws.Activate
myCat.ActiveConnection = "provider=microsoft.jet.oledb.4.0;" _
      & " data source=" & myData
On Error Resume Next
myCat.Tables.Delete ws.Range("B1").Value
On Error GoTo 0
myIdx.Name = "PrimaryKey"
myIdx.PrimaryKey = True
With myTable
      .Name = ws.Range("B1").Value
      For i = 4 To ws.Range("A65536").End(xlUp).Row
         Set myColumn = New Column
         With myColumn
            .Name = ws.Cells(i, 1).Value
            .Type = GetConstNo(ws.Cells(i, 2).Value)
            If ws.Cells(i, 3).Value > 0 Then
                  .DefinedSize = ws.Cells(i, 3).Value
                  .Attributes = adColNullable
            End If
         End With
         .Columns.Append myColumn
         If ws.Cells(i, 4).Value = "是" Then
            myIdx.Columns.Append ws.Cells(i, 1).Value
         End If
      Next
End With
myCat.Tables.Append myTable
myTable.Indexes.Append myIdx
MsgBox "数据表<" & ws.Range("B1").Value & ">创建成功！", _
      vbOKOnly + vbInformation, "创建数据表"
Set ws = Nothing
Set myIdx = Nothing
Set myTable = Nothing
Set myCat = Nothing
End Sub

Function GetConstNo(myStr As String) As Integer
Select Case myStr
      Case "adBigInt": GetConstNo = 20
      Case "adBinary": GetConstNo = 128
      Case "adBoolean": GetConstNo = 11
      Case "adBSTR": GetConstNo = 8
      Case "adChapter": GetConstNo = 136
      Case "adChar": GetConstNo = 129
      Case "adCurrency": GetConstNo = 6
      Case "adDate": GetConstNo = 7
      Case "adDBDate": GetConstNo = 133
      Case "adDBTime": GetConstNo = 134
      Case "adDBTimeStamp": GetConstNo = 135
      Case "adDecimal": GetConstNo = 14
      Case "adDouble": GetConstNo = 5
      Case "adEmpty": GetConstNo = 0
      Case "adError": GetConstNo = 10
      Case "adFileTime": GetConstNo = 64
      Case "adGUID": GetConstNo = 72
      Case "adIDispatch": GetConstNo = 9
      Case "adInteger": GetConstNo = 3
      Case "adIUnknown": GetConstNo = 13
      Case "adLongVarBinary": GetConstNo = 205
      Case "adLongVarChar": GetConstNo = 201
      Case "adLongVarWChar": GetConstNo = 203
      Case "adNumeric": GetConstNo = 131
      Case "adPropVariant": GetConstNo = 138
      Case "adSingle": GetConstNo = 4
      Case "adSmallInt": GetConstNo = 2
      Case "adTinyInt": GetConstNo = 16
      Case "adUnsignedBigInt": GetConstNo = 21
      Case "adUnsignedInt": GetConstNo = 19
      Case "adUnsignedSmallInt": GetConstNo = 18
      Case "adUnsignedTinyInt": GetConstNo = 17
      Case "adUserDefined": GetConstNo = 132
      Case "adVarBinary": GetConstNo = 204
      Case "adVarChar": GetConstNo = 200
      Case "adVariant": GetConstNo = 12
      Case "adVarNumeric": GetConstNo = 139
      Case "adVarWChar": GetConstNo = 202
      Case "adWChar": GetConstNo = 130
      Case Else: GetConstNo = -1
End Select
End Function
利用工作表数据创建数据表方法2.xls的代码:
Public Sub 利用工作表数据创建数据表方法2()
Dim cnn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim ws As Worksheet
Dim i As Long
Dim myData As String, SQL As String
myData = ThisWorkbook.Path & "\学生成绩管理.mdb"
On Error Resume Next
Set ws = Worksheets("数据表设计")
On Error GoTo 0
If ws Is Nothing Then
      MsgBox "没有数据表资料存在！", vbCritical, "警告"
      Exit Sub
End If
ws.Activate
Set cnn = New ADODB.Connection
With cnn
      .Provider = "microsoft.jet.oledb.4.0"
      .Open myData
End With
On Error Resume Next
SQL = "drop table " & ws.Range("B1").Value
Set rs = cnn.Execute(SQL)
On Error GoTo 0
SQL = "create table " & ws.Range("B1").Value & "("
For i = 4 To ws.Range("A65536").End(xlUp).Row
      SQL = SQL & ws.Cells(i, 1).Value & " " & ws.Cells(i, 2).Value
      If ws.Cells(i, 3).Value > 0 Then
         SQL = SQL & "(" & ws.Cells(i, 3).Value & ")"
      End If
      If ws.Cells(i, 4).Value = "是" Then
         SQL = SQL & " primary key"
      End If
      SQL = SQL & ","
Next
SQL = Left(SQL, Len(SQL) - 1) & ")"
Set rs = cnn.Execute(SQL)
MsgBox "数据表<" & ws.Range("B1").Value & ">创建成功！", _
      vbOKOnly + vbInformation, "创建数据表"
cnn.Close
Set ws = Nothing
Set rs = Nothing
Set cnn = Nothing
End Sub

zez · 发表于 2010-9-1 19:25

原帖由 wach 于 2010-9-1 17:58 发表
谢谢楼主的分享!但我下载了前几个表(创建数据库,创建数据表等)全是空的EXCEL表没有宏没控件之类!

8楼利用工作表数据创建数据表方法3.xls的代码:
Public Sub 利用工作表数据创建数据表方法3()
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
myData = ThisWorkbook.Path & "\学生成绩管理.mdb"
On Error Resume Next
Set ws = Worksheets("数据表设计")
On Error GoTo 0
If ws Is Nothing Then
      MsgBox "没有数据表资料存在！", vbCritical, "警告"
      Exit Sub
End If
ws.Activate
Set myDb = OpenDatabase(myData)
On Error Resume Next
myDb.TableDefs.Delete Range("B1").Value
On Error GoTo 0
Set myTable = myDb.CreateTableDef(Range("B1").Value)
Set myIndex = myTable.CreateIndex("PrimaryKey")
myIndex.Primary = True
For i = 4 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 "数据表<" & ws.Range("B1").Value & ">创建成功！", _
      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

zy040059 · 发表于 2010-9-1 22:15

学无止境，感谢楼主的无私奉献，受教了。

19980919hy · 发表于 2010-9-2 11:57

正愁EXCEL数据量大的比较分析，需从ACCESS中提数分析的方法，谢谢楼主！

wach · 发表于 2010-9-2 16:09

谢谢楼主!我是初学者!太笨了!今天终于在样表中找到了代码了!

逍遥007 · 发表于 2010-9-3 05:47

全部下载，谢谢分享

		自动登录	找回密码
密码			免费注册