[已解决]求助各位VBA专家，如何把数据写入工作表的代码改成写入Microsoft Access数据库

qinhuan66 · 发表于 2013-3-29 15:17

求助A5到S65536的数据是根据生成个人数据按纽（在数据库文件夹中的各个镇文件夹）提取出来的。各位老师能否帮改写成定入2003Microsoft Access数据库。谢谢

2013年3月29日 - 测试.rar (161.45 KB, 下载次数: 89)

2013-3-29 15:17 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-3-30 22:08

Sub 导出ACCESS()
Dim AccessFile As String, Database As String, SQL As String
Dim StrConn$, strSQL$
Dim lLastrow&
Dim arr, i&, j As Byte
Dim AdoxCat As Object
Dim AdoCmd As Object
Dim AdoConn As Object
Dim AdoRst As Object
On Error GoTo Errcheck
AccessFile = ThisWorkbook.Path & "\test.mdb"
Database = "个人数据"
If Dir(AccessFile) = "" Then
'检测文件是否存在，不存在则创建数据库
Set AdoxCat = CreateObject("adox.catalog")
AdoxCat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AccessFile
Set AdoConn = AdoxCat.ActiveConnection
Set AdoCmd = CreateObject("ADODB.Command")
Set AdoCmd.ActiveConnection = AdoConn
AdoCmd.CommandText = "CREATE TABLE " & Database & _
" (序号 text(5),姓名 text(10),生产组 text(20),身份证号码 text(18)," & _
"年龄 TINYINT,合计 REAL,正常发放小计 REAL,正常发放基础养老金 REAL," & _
"正常发放个人帐户 REAL,补发放小计 REAL,补发放基础养老金 REAL," & _
"补发放个人帐户 REAL,账号 text(20),备注 text(100),社会保障号 text(20)," & _
"电话号码 text(20),参保性质 text(10),补充说明 text(20),所在社区 text(20));"
AdoCmd.Execute , , 1 'adCmdText
Set AdoCmd = Nothing
Set AdoxCat = Nothing
Set AdoConn = Nothing
End If
StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & AccessFile & ";"""
Set AdoConn = CreateObject("ADODB.Connection")
AdoConn.Open StrConn
If AdoConn.State <> 1 Then MsgBox "数据库连接失败", vbCritical + vbOKOnly: Exit Sub
lLastrow = Cells(Rows.Count, 1).End(xlUp).Row
If lLastrow < 5 Then Exit Sub
arr = Range("a5:s" & lLastrow)
strSQL = "select * from " & Database
Set AdoRst = CreateObject("ADODB.Recordset")
AdoRst.Open strSQL, AdoConn, 2, 3 'adOpenDynamic, adLockOptimistic
With AdoRst
For i = LBound(arr) To UBound(arr)
.AddNew
For j = 1 To UBound(arr, 2)
.Fields(j - 1).Value = arr(i, j)
Next
.Update
Next
End With
AdoRst.Close
Set AdoRst = Nothing
Set AdoConn = Nothing
MsgBox "数据改入成功" & vbNewLine & _
AccessFile & vbNewLine, vbInformation + vbOKOnly
Exit Sub
Errcheck:
MsgBox Err.Number & vbNewLine & _
Err.Description
End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy · 发表于 2013-3-29 15:28

用SQL嘛，这种场合就得。

hwc2ycy · 发表于 2013-3-29 15:29

数据库里可不会有多级标题的。

qinhuan66 · 发表于 2013-3-29 15:32

hwc2ycy 发表于 2013-3-29 15:29
数据库里可不会有多级标题的。

你好楼主这个我知道就能写信该写的信息即可谢谢因为提到工作表数据量大反应慢

hwc2ycy · 发表于 2013-3-29 16:04

晚上写吧，要下班了，这个还得整理思路。

qinhuan66 · 发表于 2013-3-29 16:09

hwc2ycy 发表于 2013-3-29 16:04
晚上写吧，要下班了，这个还得整理思路。

好的谢谢老师

hwc2ycy · 发表于 2013-3-30 22:08

这个最佳答案由 hwc2ycy 给出，感谢 hwc2ycy 的回答。

单击隐藏图章

Sub 导出ACCESS()
Dim AccessFile As String, Database As String, SQL As String
Dim StrConn$, strSQL$
Dim lLastrow&
Dim arr, i&, j As Byte
Dim AdoxCat As Object
Dim AdoCmd As Object
Dim AdoConn As Object
Dim AdoRst As Object
On Error GoTo Errcheck
AccessFile = ThisWorkbook.Path & "\test.mdb"
Database = "个人数据"
If Dir(AccessFile) = "" Then
'检测文件是否存在，不存在则创建数据库
Set AdoxCat = CreateObject("adox.catalog")
AdoxCat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AccessFile
Set AdoConn = AdoxCat.ActiveConnection
Set AdoCmd = CreateObject("ADODB.Command")
Set AdoCmd.ActiveConnection = AdoConn
AdoCmd.CommandText = "CREATE TABLE " & Database & _
" (序号 text(5),姓名 text(10),生产组 text(20),身份证号码 text(18)," & _
"年龄 TINYINT,合计 REAL,正常发放小计 REAL,正常发放基础养老金 REAL," & _
"正常发放个人帐户 REAL,补发放小计 REAL,补发放基础养老金 REAL," & _
"补发放个人帐户 REAL,账号 text(20),备注 text(100),社会保障号 text(20)," & _
"电话号码 text(20),参保性质 text(10),补充说明 text(20),所在社区 text(20));"
AdoCmd.Execute , , 1 'adCmdText
Set AdoCmd = Nothing
Set AdoxCat = Nothing
Set AdoConn = Nothing
End If
StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & AccessFile & ";"""
Set AdoConn = CreateObject("ADODB.Connection")
AdoConn.Open StrConn
If AdoConn.State <> 1 Then MsgBox "数据库连接失败", vbCritical + vbOKOnly: Exit Sub
lLastrow = Cells(Rows.Count, 1).End(xlUp).Row
If lLastrow < 5 Then Exit Sub
arr = Range("a5:s" & lLastrow)
strSQL = "select * from " & Database
Set AdoRst = CreateObject("ADODB.Recordset")
AdoRst.Open strSQL, AdoConn, 2, 3 'adOpenDynamic, adLockOptimistic
With AdoRst
For i = LBound(arr) To UBound(arr)
.AddNew
For j = 1 To UBound(arr, 2)
.Fields(j - 1).Value = arr(i, j)
Next
.Update
Next
End With
AdoRst.Close
Set AdoRst = Nothing
Set AdoConn = Nothing
MsgBox "数据改入成功" & vbNewLine & _
AccessFile & vbNewLine, vbInformation + vbOKOnly
Exit Sub
Errcheck:
MsgBox Err.Number & vbNewLine & _
Err.Description
End Sub

复制代码

hwc2ycy · 发表于 2013-3-31 13:59

列的长度如果写入的时候报错了，你就改下，删除原有的MDB文件后人重新建的。

hwc2ycy · 发表于 2013-3-31 18:50

其实可以直接在ACCESS里直接导入的，把标题行处理下就成了。

qinhuan66 · 发表于 2013-4-2 10:54

hwc2ycy 发表于 2013-3-31 18:50
其实可以直接在ACCESS里直接导入的，把标题行处理下就成了。

求助hwc2ycy老师：如何生成浅绿色区域的数据生成到2003Microsoft Access数据库，以委托日期、今收到的姓名和人民币合计金额为准3者相同（如图一）不能重复提交到数据库。
如没数据库自动新建数据库。谢谢。

社会保险基金专用收款收据.rar (10.35 KB, 下载次数: 6)

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

[已解决]求助各位VBA专家，如何把数据写入工作表的代码改成写入Microsoft Access数据库

相关帖子

评分