[已解决]高难度的求助：获取数据库某条信息进行资料修改；后如何替换原先的本条记录数据。谢谢

qinhuan66 · 发表于 2013-6-7 13:03

求助老师：黄色区域的资料是根据在B3单元格输入姓名(李四)点击获取数据按纽从Access数据库提取出来。现在我想修改数据库李四的个人信息(如：当前民族为白族；我想改为汉族）后再保存本条李四的信息保存。注意：只能覆盖当前数据库的记录，不能新建数据库记录。如何修改这条代码呢。谢谢！

测试.rar (166.78 KB, 下载次数: 33)

2013-6-7 12:55 上传

点击文件名下载附件

要达到的效果图1、图2的青圈内的民族前后对比
图1：修改获取数据前

图2：修改保存后

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-6-7 14:38

原来引用的是SHEET1，现在是SHEET3了，

Sub 修改数据库()
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 & "\gkzp.mdb"
Database = "gkzp"
If Dir(AccessFile) = "" Then
'检测文件是否存在，不存在则创建数据库
Set AdoxCat = CreateObject("adox.catalog")
AdoxCat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AccessFile & ";Jet OLEDB:Database Password=695360052;"
Set AdoConn = AdoxCat.ActiveConnection
Set AdoCmd = CreateObject("ADODB.Command")
Set AdoCmd.ActiveConnection = AdoConn
AdoCmd.CommandText = "CREATE TABLE " & Database & _
" (报名序号 text(3),报名时间 datetime ,报考类别 text(30),操作员 text(6),姓名 text(8),性别 text(2),出生日期 datetime ,籍贯 text(30),民族 text(10)," & _
"政治面貌 text(20),健康状况 text(20),参加工作时间 datetime ,最高学历毕业时间 datetime ,移动电话 text(12),固定电话 text(11),身份证号 text(18),电子邮箱 text(20)," & _
"现工作单位及职务（或家庭住址） text(50),报考职位 text(50),全日制教育 text(50),全日制教育毕业院校及专业 text(50),在职教育 text(50),在职教育毕业院校及专业 text(50),学习工作简历 text(50),提供材料 text(120),资格审查情况 text(6))"
AdoCmd.Execute
Set AdoCmd = Nothing
Set AdoxCat = Nothing
Set AdoConn = Nothing
End If
If Len([B3]) = 0 Or Len([F3]) = 0 Or Len([J3]) = 0 Or Len([B4]) = 0 Or Len([F4]) = 0 Or Len([J4]) = 0 Or Len([B5]) = 0 Or Len([F5]) = 0 Or Len([J5]) = 0 Or Len([C6]) = 0 Or Len([J6]) = 0 Or Len([C7]) = 0 Or Len([J7]) = 0 Or Len([E8]) = 0 Or Len([E9]) = 0 Or Len([D10]) = 0 Or Len([I10]) = 0 Or Len([D11]) = 0 Or Len([I11]) = 0 Or Len([B12]) = 0 Then
MsgBox "对不起！黄色区域数据输入不完整，请先填好数据再进行提交。"
Exit Sub
End If
StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source='" & AccessFile & "';jet oledb:Database Password=695360052"
Set AdoConn = CreateObject("ADODB.Connection")
With AdoConn
.CursorLocation = 3
.Mode = 3
.CommandTimeout = 5
.connectionTimeout = 5
.Open StrConn
End With
strSql = "select * from " & Database & " where 报名时间=#" & [L4] & "# " & " and 性别 like '" & [F3] & "' and 身份证号='" & [C7] & "'"
Dim strTGCL$ '提供材料
Dim strZGSCQK$ '资格审查情况
Dim item1
With Sheet3
For Each item1 In .OLEObjects '控件遍历
With item1
If .Name Like "CheckBox*" Then '过滤非CHECKBOX
Select Case True
Case .Object.Value And .TopLeftCell.Row = 17 '17行的数据
strTGCL = strTGCL & .Object.Caption & ","
Case .Object.Value And .TopLeftCell.Row = 22 '22行的数据
strZGSCQK = strZGSCQK & item1.Object.Caption & ","
End Select
End If
End With
Next
End With
If Len(strTGCL) Then
strTGCL = Left(strTGCL, Len(strTGCL) - 1) '过滤最后的","
Else
strTGCL = "无"
End If
[b17] = strTGCL
If Len(strZGSCQK) Then
strZGSCQK = Left(strZGSCQK, Len(strZGSCQK) - 1) '过滤最后的","
Else
strZGSCQK = "无"
End If
[b22] = strZGSCQK
Set AdoRst = CreateObject("adodb.recordset")
AdoRst.Open strSql, AdoConn, 0, 3
If AdoRst.RecordCount = 0 Then '
strSql = " insert into " & Database & " values('" & [L3] & "',#" & [L4] & "#,'" & [L5] & "','" & [L6] & "','" & [B3] & "','" & [F3] & "',#" & [J3] & "#,'" & [B4] & "','" & [F4] & "','" & _
[J4] & "','" & [B5] & "',#" & [F5] & "#,'" & [J5] & "','" & [C6] & "','" & [J6] & "','" & [C7] & "','" & [J7] & "','" & _
[E8] & "','" & [E9] & "','" & [D10] & "','" & [I10] & "','" & [D11] & "','" & [I11] & "','" & [B12] & "','" & strTGCL & "','" & strZGSCQK & "')"
AdoConn.Execute strSql
MsgBox "呵呵！本次数据已成功添加的数据库"
[B3:C3,F3:G3,J3,L3,B4:C4,F4:G4,J4,L4,B5:C5,F5:G5,J5,L5,C6:G6,J6,L6,C7:G7,J7:L7,E8:L8,E9:L9,D10:F10,I10:L10,D11:F11,I11:L11,B12:L16] = ""
[L3] = [L3] + 1
'清除单选框
With Sheet1
For Each item1 In .OLEObjects '控件遍历
With item1
Select Case TypeName(.Object)
Case "CheckBox"
.Object.Value = False
End Select
End With
Next
End With
Else
strSql = "upate " & Database & " set "
Dim m As Integer
Dim rg As Range, rg1 As Range
Set rg = Range("L3,L4,L5,L6,B3,F3,J3,B4,F4,J4,B5,F5,J5,C6,J6,C7,J7,E8,E9,D10,I10,D11,I11,B12,b17,b22")
With AdoRst
For Each rg1 In rg
Debug.Print .Fields(m).Value
.Fields(m).Value = rg1.Value
Debug.Print .Fields(m).Value
m = m + 1
'Stop
Next
.Update
MsgBox "更新完成"
End With
[b17] = ""
[b22] = ""
End If
AdoConn.Close
Set AdoConn = Nothing
Exit Sub
Errcheck:
MsgBox Err.Number & vbNewLine & _
Err.Description
End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy · 发表于 2013-6-7 13:14

你昨天那样不是很好的嘛。

qinhuan66 · 发表于 2013-6-7 13:16

hwc2ycy 发表于 2013-6-7 13:14
你昨天那样不是很好的嘛。

今天检查不行呀，不能替换了，只能重新生成新的一条记录

，唉就差这么一步了。

hwc2ycy · 发表于 2013-6-7 13:35

strSql = "select * from " & Database & " where 报名时间=#" & [L4] & "# " & " and 性别 like '" & [B3] & "' and 身份证号='" & [C7] & "'"
这句有问题，性别匹配成了姓名。

qinhuan66 · 发表于 2013-6-7 13:46

本帖最后由 qinhuan66 于 2013-6-7 13:51 编辑

hwc2ycy 发表于 2013-6-7 13:35
strSql = "select * from " & Database & " where 报名时间=#" & [L4] & "# " & " and 性别 like '" & & " ...

教师经测试好多遍都提示记录已存在不能添加

修改这几个值后strSql = "select * from " & Database & " where 报名时间=#" & [L4] & "# " & " and 性别 like '" & [F3] & "' and 身份证号='" & [C7] & "'"后可以提交，但是也回到标题一样，水能够替换原先的那条数据，还有复选框的那些内容还是写不进数据库

hwc2ycy · 发表于 2013-6-7 13:50

你得先解决数据重复的问题，通过报考时间和身份证号码，应该不会同一个人在同一时间报两次吧。

hwc2ycy · 发表于 2013-6-7 13:52

这个代码本来就不是修改的嘛，你这个按钮里用的是添加的代码。

qinhuan66 · 发表于 2013-6-7 13:53

本帖最后由 qinhuan66 于 2013-6-7 13:54 编辑

hwc2ycy 发表于 2013-6-7 13:50
你得先解决数据重复的问题，通过报考时间和身份证号码，应该不会同一个人在同一时间报两次吧。

如果是修改的能否不用重复项，反正都是修改的

那怎么改才能成为修改的呢，现在最主要的是修改，其他你都已帮我完成了。谢谢

hwc2ycy · 发表于 2013-6-7 14:15

Sub 修改数据库()
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 & "\gkzp.mdb"
Database = "gkzp"
If Dir(AccessFile) = "" Then
'检测文件是否存在，不存在则创建数据库
Set AdoxCat = CreateObject("adox.catalog")
AdoxCat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AccessFile & ";Jet OLEDB:Database Password=695360052;"
Set AdoConn = AdoxCat.ActiveConnection
Set AdoCmd = CreateObject("ADODB.Command")
Set AdoCmd.ActiveConnection = AdoConn
AdoCmd.CommandText = "CREATE TABLE " & Database & _
" (报名序号 text(3),报名时间 datetime ,报考类别 text(30),操作员 text(6),姓名 text(8),性别 text(2),出生日期 datetime ,籍贯 text(30),民族 text(10)," & _
"政治面貌 text(20),健康状况 text(20),参加工作时间 datetime ,最高学历毕业时间 datetime ,移动电话 text(12),固定电话 text(11),身份证号 text(18),电子邮箱 text(20)," & _
"现工作单位及职务（或家庭住址） text(50),报考职位 text(50),全日制教育 text(50),全日制教育毕业院校及专业 text(50),在职教育 text(50),在职教育毕业院校及专业 text(50),学习工作简历 text(50),提供材料 text(120),资格审查情况 text(6))"
AdoCmd.Execute
Set AdoCmd = Nothing
Set AdoxCat = Nothing
Set AdoConn = Nothing
End If
If Len([B3]) = 0 Or Len([F3]) = 0 Or Len([J3]) = 0 Or Len([B4]) = 0 Or Len([F4]) = 0 Or Len([J4]) = 0 Or Len([B5]) = 0 Or Len([F5]) = 0 Or Len([J5]) = 0 Or Len([C6]) = 0 Or Len([J6]) = 0 Or Len([C7]) = 0 Or Len([J7]) = 0 Or Len([E8]) = 0 Or Len([E9]) = 0 Or Len([D10]) = 0 Or Len([I10]) = 0 Or Len([D11]) = 0 Or Len([I11]) = 0 Or Len([B12]) = 0 Then
MsgBox "对不起！黄色区域数据输入不完整，请先填好数据再进行提交。"
Exit Sub
End If
StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
"Data Source='" & AccessFile & "';jet oledb:Database Password=695360052"
Set AdoConn = CreateObject("ADODB.Connection")
With AdoConn
.CursorLocation = 3
.Mode = 3
.CommandTimeout = 5
.connectionTimeout = 5
.Open StrConn
End With
strSql = "select * from " & Database & " where 报名时间=#" & [L4] & "# " & " and 性别 like '" & [F3] & "' and 身份证号='" & [C7] & "'"
Dim strTGCL$ '提供材料
Dim strZGSCQK$ '资格审查情况
Dim item1
With Sheet1
For Each item1 In .OLEObjects '控件遍历
With item1
If .Name Like "CheckBox*" Then '过滤非CHECKBOX
Select Case True
Case .Object.Value And .TopLeftCell.Row = 17 '17行的数据
strTGCL = strTGCL & .Object.Caption & ","
Case .Object.Value And .TopLeftCell.Row = 22 '22行的数据
strZGSCQK = strZGSCQK & item1.Object.Caption & ","
End Select
End If
End With
Next
End With
If Len(strTGCL) Then
strTGCL = Left(strTGCL, Len(strTGCL) - 1) '过滤最后的","
Else
strTGCL = "无"
End If
[b17] = strTGCL
If Len(strZGSCQK) Then
strZGSCQK = Left(strZGSCQK, Len(strZGSCQK) - 1) '过滤最后的","
Else
strZGSCQK = "无"
End If
[b22] = strZGSCQK
Set AdoRst = CreateObject("adodb.recordset")
AdoRst.Open strSql, AdoConn, 0, 3
If AdoRst.RecordCount = 0 Then '
strSql = " insert into " & Database & " values('" & [L3] & "',#" & [L4] & "#,'" & [L5] & "','" & [L6] & "','" & [B3] & "','" & [F3] & "',#" & [J3] & "#,'" & [B4] & "','" & [F4] & "','" & _
[J4] & "','" & [B5] & "',#" & [F5] & "#,'" & [J5] & "','" & [C6] & "','" & [J6] & "','" & [C7] & "','" & [J7] & "','" & _
[E8] & "','" & [E9] & "','" & [D10] & "','" & [I10] & "','" & [D11] & "','" & [I11] & "','" & [B12] & "','" & strTGCL & "','" & strZGSCQK & "')"
AdoConn.Execute strSql
MsgBox "呵呵！本次数据已成功添加的数据库"
[B3:C3,F3:G3,J3,L3,B4:C4,F4:G4,J4,L4,B5:C5,F5:G5,J5,L5,C6:G6,J6,L6,C7:G7,J7:L7,E8:L8,E9:L9,D10:F10,I10:L10,D11:F11,I11:L11,B12:L16] = ""
[L3] = [L3] + 1
'清除单选框
With Sheet1
For Each item1 In .OLEObjects '控件遍历
With item1
Select Case TypeName(.Object)
Case "CheckBox"
.Object.Value = False
End Select
End With
Next
End With
Else
strSql = "upate " & Database & " set "
Dim m As Integer
Dim rg As Range, rg1 As Range
Set rg = Range("L3,L4,L5,L6,B3,F3,J3,B4,F4,J4,B5,F5,J5,C6,J6,C7,J7,E8,E9,D10,I10,D11,I11,B12,b17,b22")
With AdoRst
For Each rg1 In rg
Debug.Print .Fields(m).Value
.Fields(m).Value = rg1.Value
Debug.Print .Fields(m).Value
m = m + 1
'Stop
Next
.Update
MsgBox "更新完成"
End With
End If
AdoConn.Close
Set AdoConn = Nothing
Exit Sub
Errcheck:
MsgBox Err.Number & vbNewLine & _
Err.Description
End Sub

复制代码

hwc2ycy · 发表于 2013-6-7 14:16

如果查到有多条同样的记录的话，现在只更新第一条。

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