标题: excel无法导入access? [打印本页] 作者: juzhengli2005 时间: 2010-10-14 17:23 标题: excel无法导入access? excel表格无法导入，都检查了好几偏单元格格式，还是不对。请问是啥原因呢？ 作者: juzhengli2005 时间: 2010-10-14 17:25 标题: RE: excel无法导入access? 提示错误：如图作者: jiahongyu 时间: 2010-10-14 19:38
Public Sub 添加记录并更新()
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
***********************************重新修改后***********
Sub 添加记录并更新()
Dim cnn As New ADODB.Connection
Dim strPath As String
Dim rw As Range
Dim strSQL As String
Dim R As Long
R = [A65536].End(xlUp).Row
If R < 2 Then
MsgBox "没有数据要更新！"
Exit Sub
End If
strPath = ThisWorkbook.Path & "\学生管理.mdb"
cnn.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & strPath
For Each rw In Range("A2:A" & R).EntireRow.Rows
strSQL = "UPDATE 学生信息 SET [姓名]='" & rw.Cells(2) & "', [性别]='" & rw.Cells(3) & "', [系别]='" _
& rw.Cells(4) & "', [班级]='" & rw.Cells(5) & "', [面貌]='" & rw.Cells(6) & "', [出生日期]=#" _
& rw.Cells(7) & "#, [籍贯]='" & rw.Cells(8) & "' where [学号]='" & rw.Cells(1) & "'"
cnn.Execute (strSQL)
strSQL = ""
Next rw
Set cnn = Nothing