[已解决]老师如何修改复盖当前Access数据库的数据表记录的内容

qinhuan66

hwc2ycy 发表于 2013-6-6 23:05
你得把查到的记录里 提供材料，资格审查情况 这两个字段值，用，号连接起来，替换掉STRTEST就成了。

测试.rar (170.33 KB, 下载次数: 9)

2013-6-6 23:18 上传

点击文件名下载附件
arr = Split(INSTR, ",")   这行变红色


Sub 数据值到控件()
    Dim INSTR
    Dim arr, a
    Dim item1 As Object
    Dim objDic As Object
    Set objDic = CreateObject("scripting.dictionary")


    INSTR = "身份证,毕业证,学位证,户籍薄,会计从业资格证,存档证明,专业技术资格证,单位同意报考证明,基层工作经历证明,通过,不通过"
    arr = Split(INSTR, ",")
    For Each a In arr
        objDic(a) = ""
    Next

    With Sheet3
        For Each item1 In .OLEObjects   '控件遍历
            With item1
                Select Case TypeName(.Object)
                    Case "CheckBox"
                        Select Case True
                            Case objDic.exists(.Object.Caption)
                                .Object.Value = True
                        End Select
                End Select
            End With
        Next
    End With
    Set objDic = Nothing
End Sub

Sub 取消控件选择()
    Dim item1 As Object
    '清除单选框
    With Sheet3
        For Each item1 In .OLEObjects   '控件遍历
            With item1
                Select Case TypeName(.Object)
                    Case "CheckBox"
                        .Object.Value = False
                End Select
            End With
        Next
    End With

End Sub

hwc2ycy

INSTR是函数名，这是保留的，不能当变量名使。

1. Sub 数据值到控件()
   
2.     Dim strTest
   
3.     Dim arr, a
   
4.     Dim item1 As Object
   
5.     Dim objDic As Object
   
6.     Set objDic = CreateObject("scripting.dictionary")
   
7. 
   
8. 
   
9.     strTest = "身份证,毕业证,学位证,户籍薄,会计从业资格证,存档证明,专业技术资格证,单位同意报考证明,基层工作经历证明,通过,不通过"
   
10.     arr = Split(strTest, ",")
    
11.     For Each a In arr
    
12.         objDic(a) = ""
    
13.     Next
    
14. 
    
15.     With Sheet3
    
16.         For Each item1 In .OLEObjects   '控件遍历
    
17.             With item1
    
18.                 Select Case TypeName(.Object)
    
19.                     Case "CheckBox"
    
20.                         Select Case True
    
21.                             Case objDic.exists(.Object.Caption)
    
22.                                 .Object.Value = True
    
23.                         End Select
    
24.                 End Select
    
25.             End With
    
26.         Next
    
27.     End With
    
28.     Set objDic = Nothing
    
29. End Sub
    
30. 
    
31. Sub 取消控件选择()
    
32.     Dim item1 As Object
    
33.     '清除单选框
    
34.     With Sheet3
    
35.         For Each item1 In .OLEObjects   '控件遍历
    
36.             With item1
    
37.                 Select Case TypeName(.Object)
    
38.                     Case "CheckBox"
    
39.                         .Object.Value = False
    
40.                 End Select
    
41.             End With
    
42.         Next
    
43.     End With
    
44. 
    
45. End Sub

复制代码

qinhuan66

hwc2ycy 发表于 2013-6-6 23:19
INSTR是函数名，这是保留的，不能当变量名使。

老师这段代码应该放在哪里呢？我现在放的位置写不进去

hwc2ycy

你的获取数据代码有用了？
应该放在获取数据里使用。

hwc2ycy

你的获取数据代码做好了再来弄吧。
不早了，休息吧。

qinhuan66

hwc2ycy 发表于 2013-6-6 23:33
你的获取数据代码做好了再来弄吧。
不早了，休息吧。

谢谢了！你先休息吧。真不好意思要你陪到这么深液。
你有空再帮看吧。
这是我的提取代码
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address <> "$B$3" Then Exit Sub
    If Target.Value = "" Then Exit Sub
    Dim cnn As Object, rs As Object, sql$, i&, m&, c As Range
    Set cnn = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    cnn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\gkzp.mdb;Jet OLEDB:Database Password=695360052"
    sql = "select 性别,出生日期,报名序号,籍贯,民族,政治面貌,报名时间,健康状况,参加工作时间,最高学历毕业时间,报考类别,移动电话,固定电话,操作员,身份证号,电子邮箱,现工作单位及职务（或家庭住址）,报考职位,全日制教育,全日制教育毕业院校及专业,在职教育,在职教育毕业院校及专业,学习工作简历 from gkzp where 姓名='" & Target.Value & "'"
    rs.Open sql, cnn, 1, 3
    If rs.RecordCount > 0 Then
        If rs.RecordCount > 1 Then
'            MsgBox Target.Value & "共有" & rs.RecordCount & "条记录", vbInformation
            For i = 1 To rs.RecordCount
                m = 0
                For Each c In Range("F3,J3,L3,B4,F4,J4,L4,B5,F5,J5,L5,C6,J6,L6,C7,J7,E8,E9,D10,I10,D11,I11,B12")
                    c.Value = rs.Fields(m).Value
                    m = m + 1
                Next
                If i < rs.RecordCount Then
                    If MsgBox("共有" & rs.RecordCount & "条记录，这是第" & i & "条记录，单击“是”显示下一条，单击“否”退出程序。", vbInformation + vbYesNo, Target.Value & "共有" & rs.RecordCount & "条记录") = vbNo Then Exit For
                End If
                rs.MoveNext
            Next
        Else

            For Each c In Range("F3,J3,L3,B4,F4,J4,L4,B5,F5,J5,L5,C6,J6,L6,C7,J7,E8,E9,D10,I10,D11,I11,B12")
                c.Value = rs.Fields(m).Value
                m = m + 1
            Next
            MsgBox "呵呵！获取成功！"  '提示可要可不要
        End If
    Else
        Range("F3,J3,L3,B4,F4,J4,L4,B5,F5,J5,L5,C6,J6,L6,C7,J7,E8,E9,D10,I10,D11,I11,B12") = ""
    End If
    rs.Close
    Set rs = Nothing
    cnn.Close
    Set cnn = Nothing
End Sub

hwc2ycy

这个RANGE用法还不错，学习下。

这里如果用CHANGE事件的话，就得先屏蔽事件响应，否则代码就会陷入死循环了。

hwc2ycy

获取数据按钮的代码

1. Private Sub CommandButton2_Click()
   
2. 
   
3.     Dim cnn As Object, rs As Object, sql$, i&, m&, c As Range
   
4.     If Len(Range("b3").Value) = 0 Then MsgBox " 请在 B3 单元可输入要查询的姓名", vbCritical + vbOKOnly: Exit Sub
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Application.EnableEvents = False
   
8.     Set cnn = CreateObject("adodb.connection")
   
9.     Set rs = CreateObject("adodb.recordset")
   
10. 
    
11.     cnn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\gkzp.mdb;Jet OLEDB:Database Password=695360052"
    
12. 
    
13.     sql = "select 性别,出生日期,报名序号,籍贯,民族,政治面貌,报名时间,健康状况,参加工作时间,最高学历毕业时间,报考类别,移动电话,固定电话,操作员,身份证号,电子邮箱,现工作单位及职务（或家庭住址）,报考职位,全日制教育,全日制教育毕业院校及专业,在职教育,在职教育毕业院校及专业,学习工作简历,提供材料,资格审查情况 from gkzp where 姓名='" & [b3] & "'"
    
14.     rs.Open sql, cnn, 1, 3
    
15.     If rs.RecordCount > 0 Then
    
16.         If rs.RecordCount > 1 Then
    
17.             '            MsgBox Target.Value & "共有" & rs.RecordCount & "条记录", vbInformation
    
18.             For i = 1 To rs.RecordCount
    
19.                 m = 0
    
20.                 For Each c In Range("F3,J3,L3,B4,F4,J4,L4,B5,F5,J5,L5,C6,J6,L6,C7,J7,E8,E9,D10,I10,D11,I11,B12,B17,B22")
    
21.                     c.Value = rs.Fields(m).Value
    
22.                     m = m + 1
    
23.                 Next
    
24.                 Call 取消控件选择
    
25.                 Call 数据值到控件([b17] & "," & [b22]): [b17] = "": [b22] = ""
    
26. 
    
27.                 If i < rs.RecordCount Then
    
28.                     If MsgBox("共有" & rs.RecordCount & "条记录，这是第" & i & "条记录，单击“是”显示下一条，单击“否”退出程序。", vbInformation + vbYesNo, [b3] & "共有" & rs.RecordCount & "条记录") = vbNo Then Exit For
    
29.                 End If
    
30.                 rs.MoveNext
    
31.             Next
    
32.         Else
    
33. 
    
34.             For Each c In Range("F3,J3,L3,B4,F4,J4,L4,B5,F5,J5,L5,C6,J6,L6,C7,J7,E8,E9,D10,I10,D11,I11,B12,B17,B22")
    
35.                 c.Value = rs.Fields(m).Value
    
36.                 m = m + 1
    
37.             Next
    
38.             Call 数据值到控件([b17] & "," & [b22]): [b17] = "": [b22] = ""
    
39.             MsgBox "呵呵！获取成功！"  '提示可要可不要
    
40.         End If
    
41.     Else
    
42.         Range("F3,J3,L3,B4,F4,J4,L4,B5,F5,J5,L5,C6,J6,L6,C7,J7,E8,E9,D10,I10,D11,I11,B12") = ""
    
43.     End If
    
44.     Application.ScreenUpdating = True
    
45.     Application.DisplayAlerts = True
    
46.     Application.EnableEvents = True
    
47.     rs.Close
    
48.     Set rs = Nothing
    
49.     cnn.Close
    
50.     Set cnn = Nothing
    
51. End Sub

复制代码

hwc2ycy

配套的数据到控件值。
上面按钮的代码是在工作表里。

这两个过程放模块里，替换掉原有的这两个过程。

1. Sub 取消控件选择()
   
2.     Dim item1 As Object
   
3.     '清除单选框
   
4.     With Sheet3
   
5.         For Each item1 In .OLEObjects   '控件遍历
   
6.             With item1
   
7.                 Select Case TypeName(.Object)
   
8.                     Case "CheckBox"
   
9.                         .Object.Value = False
   
10.                 End Select
    
11.             End With
    
12.         Next
    
13.     End With
    
14. End Sub
    
15. 
    
16. Sub 数据值到控件(str As String)
    
17.     Dim arr, a
    
18.     Dim item1 As Object
    
19.     Dim objDic As Object
    
20.     Call 取消控件选择
    
21.     Set objDic = CreateObject("scripting.dictionary")
    
22.    
    
23.     arr = Split(str, ",")
    
24.     For Each a In arr
    
25.         objDic(a) = ""
    
26.     Next
    
27. 
    
28.     With Sheet3
    
29.         For Each item1 In .OLEObjects   '控件遍历
    
30.             With item1
    
31.                 Select Case TypeName(.Object)
    
32.                     Case "CheckBox"
    
33.                         Select Case True
    
34.                             Case objDic.exists(.Object.Caption)
    
35.                                 .Object.Value = True
    
36.                         End Select
    
37.                 End Select
    
38.             End With
    
39.         Next
    
40.     End With
    
41.     Set objDic = Nothing
    
42. End Sub
    

复制代码

qinhuan66

hwc2ycy 发表于 2013-6-7 07:04
获取数据按钮的代码

老师非常感谢您，这么早就起来帮我解决实际问题。这条代码非常之好用。现在是修改这条不是替换的了是重新生成的。不知错在哪？

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")

    AdoConn.CursorLocation = 3
    AdoConn.Mode = 3
    AdoConn.CommandTimeout = 5
    AdoConn.connectionTimeout = 5
    AdoConn.Open StrConn

    If AdoConn.State <> 1 Then MsgBox "数据库连接失败", vbCritical + vbOKOnly: Exit Sub

    strSql = "delete * from " & Database & " where 报名时间=#" & [L4] & "# " & " and 姓名 like '" & [b3] & "' 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

    If Len(strZGSCQK) Then
        strZGSCQK = Left(strZGSCQK, Len(strZGSCQK) - 1)  '过滤最后的","
    Else
        strZGSCQK = "无"
    End If



    'Set AdoRst =
    AdoConn.Execute (strSql)


    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

    AdoConn.Close
    Set AdoConn = Nothing
    Exit Sub

Errcheck:

    MsgBox Err.Number & vbNewLine & _
           Err.Description
End Sub