[已解决]找到对应的用户删除

ybc76

如何删除数据库里不存在的记录 删除用户名.zip (89.82 KB, 下载次数: 10)

2013-4-24 09:31 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-4-24 20:16

上面有点小错误，变量名有个写错了。

1. Option Explicit
   
2. Const adUseClient = 3
   
3. Const adModeShareDenyWrite = 8
   
4. Const adModeReadWrite = 3
   
5. 
   
6. Dim StrConn$, strSQL$
   
7. Dim AccessFile$, DataSource$
   
8. Dim strError$
   
9. Dim AdoConn As Object
   
10. Dim AdoRst As Object
    
11. 
    
12. 
    
13. Function ConnectDatabase() As Boolean
    
14.     AccessFile = "mg.mdb"
    
15.     DataSource = ThisWorkbook.Path & Application.PathSeparator & AccessFile
    
16. 
    
17.     StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
18.               "Data Source=" & DataSource & ";"""
    
19. 
    
20.     If AdoConn Is Nothing Then
    
21.         Set AdoConn = CreateObject("ADODB.Connection")
    
22.         On Error GoTo ErrCheck
    
23.         With AdoConn
    
24.             .CommandTimeout = 5
    
25.             .ConnectionTimeout = 5
    
26.             .CursorLocation = adUseClient
    
27.             .Mode = adModeReadWrite    'adModeShareDenyWrite
    
28.             .ConnectionString = StrConn
    
29.             .Open
    
30.         End With
    
31.         ConnectDatabase = True
    
32.     Else
    
33.         ConnectDatabase = True
    
34.     End If
    
35.     Exit Function
    
36. 
    
37. End1:
    
38.     Set AdoConn = Nothing
    
39.     Exit Function
    
40. 
    
41. ErrCheck:
    
42. 
    
43.     strError = Err.Number & vbCrLf & _
    
44.                Err.Description
    
45.     Resume End1
    
46. End Function
    
47. 
    
48. Sub 用户更新()
    
49. 
    
50.     If Not ConnectDatabase Then
    
51.         MsgBox strError, vbCritical
    
52.         Exit Sub
    
53.     End If
    
54. 
    
55.     strSQL = "delete from yftab"
    
56.     AdoConn.Execute strSQL
    
57. 
    
58.     Set AdoRst = CreateObject("ADODB.Recordset")
    
59.     AdoRst.Open "yftab", AdoConn, 2, 3    'adOpenDynamic, adLockOptimistic
    
60. 
    
61.     Dim lLastRow&, i&, j&
    
62.     Dim arr
    
63. 
    
64.     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
65.     If lLastRow < 3 Then Exit Sub
    
66.     arr = Range("a2:j" & lLastRow)
    
67. 
    
68.     arr(1, 1) = "gh"
    
69.     arr(1, 2) = "name"
    
70.     arr(1, 3) = "password"
    
71.     arr(1, 8) = "生产计划"
    
72. 
    
73.     Randomize (2013)
    
74. 
    
75.     With AdoRst
    
76.         For i = LBound(arr) + 1 To UBound(arr)
    
77.             .AddNew
    
78.             For j = 1 To UBound(arr, 2)
    
79.                 .Fields(arr(1, j)).Value = arr(i, j)
    
80.             Next
    
81.             .Fields("id") = (Rnd(2013) * 65536 + 1) \ 1
    
82.             .Update
    
83.         Next
    
84.     End With
    
85.     Set AdoRst = Nothing
    
86.     MsgBox "用户更新完成", vbInformation + vbOKOnly
    
87. 
    
88. End1:
    
89.     Exit Sub
    
90. 
    
91. ErrCheck:
    
92.     MsgBox Err.Number & vbCrLf & _
    
93.            Err.Description, vbCritical
    
94.     Resume End1
    
95. End Sub
    
96. 
    
97. Sub 读取用户()
    
98. 
    
99.     If Not ConnectDatabase Then
    
100.         MsgBox strError, vbCritical
     
101.         Exit Sub
     
102.     End If
     
103. 
     
104.     On Error GoTo ErrCheck
     
105. 
     
106. 
     
107.     Dim lLastRow&
     
108.     Dim arr, strFields$
     
109. 
     
110.     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
     
111.     If lLastRow < 2 Then Exit Sub
     
112. 
     
113.     arr = Range("a2:j" & lLastRow)
     
114.     If lLastRow > 2 Then Range("a3:j" & lLastRow).Value = ""
     
115.     arr(1, 1) = "gh"
     
116.     arr(1, 2) = "name"
     
117.     arr(1, 3) = "password"
     
118.     arr(1, 8) = "生产计划"
     
119. 
     
120.     arr = WorksheetFunction.Index(arr, 1, 0)
     
121.     strFields = Join(arr, ",")
     
122. 
     
123.     strSQL = "select "
     
124.     Range("a3").CopyFromRecordset AdoConn.Execute(strSQL & strFields & " from yftab")
     
125.     MsgBox "用户导入完成", vbInformation + vbOKOnly
     
126. 
     
127. End1:
     
128.     Set AdoRst = Nothing
     
129.     Exit Sub
     
130. 
     
131. ErrCheck:
     
132.     MsgBox Err.Number & vbCrLf & _
     
133.            Err.Description, vbCritical
     
134.     Resume End1
     
135. 
     
136. End Sub
     

复制代码

跳转到最佳答案楼层

sixnu

能把数据库数据导出到EXCEL里吗，那样插入一列输入函数=VLOOKUP(B9,yftab.xlsx!$C$2:$C$5,1,0)，#N/A删除，你要VBA我不会[em04]

ybc76

整个程序全部用代码编程，所以导出到excel的话，就没意义，因为系统登陆是要有一个登陆窗口的，要根据数据库里的用户名来判断

hwc2ycy

1. Option Explicit
   
2. Const adUseClient = 3
   
3. Const adModeShareDenyWrite = 8
   
4. Const adModeReadWrite = 3
   
5. 
   
6. Dim StrConn$, strSQL$
   
7. Dim AccessFile$, DataSource$
   
8. Dim strError$
   
9. Dim AdoConn As Object
   
10. Dim AdoRst As Object
    
11. 
    
12. 
    
13. Function ConnectDatabase() As Boolean
    
14.     AccessFile = "mg.mdb"
    
15.     DataSource = ThisWorkbook.Path & Application.PathSeparator & AccessFile
    
16. 
    
17.     StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
18.               "Data Source=" & DataSource & ";"""
    
19. 
    
20.     If AdoConn Is Nothing Then
    
21.         Set AdoConn = CreateObject("ADODB.Connection")
    
22.         On Error GoTo ErrCheck
    
23.         With AdoConn
    
24.             .CommandTimeout = 5
    
25.             .ConnectionTimeout = 5
    
26.             .CursorLocation = adUseClient
    
27.             .Mode = adModeReadWrite    'adModeShareDenyWrite
    
28.             .ConnectionString = StrConn
    
29.             .Open
    
30.         End With
    
31.         ConnectDatabase = True
    
32.     Else
    
33.         ConnectDatabase = True
    
34.     End If
    
35.     Exit Function
    
36. 
    
37. End1:
    
38.     Set AdoConn = Nothing
    
39.     Exit Function
    
40. 
    
41. ErrCheck:
    
42. 
    
43.     strError = Err.Number & vbCrLf & _
    
44.                Err.Description
    
45.     Resume End1
    
46. End Function
    
47. 
    
48. Sub 用户更新()
    
49. 
    
50.     If Not ConnectDatabase Then
    
51.         MsgBox strError, vbCritical
    
52.         Exit Sub
    
53.     End If
    
54. 
    
55.     strSQL = "delete from yftab"
    
56.     AdoConn.Execute strSQL
    
57. 
    
58.     Set AdoRst = CreateObject("ADODB.Recordset")
    
59.     AdoRst.Open "yftab", AdoConn, 2, 3    'adOpenDynamic, adLockOptimistic
    
60. 
    
61.     Dim lLastRow&, i&, j&
    
62.     Dim arr
    
63. 
    
64.     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
65.     If lLastRow < 3 Then Exit Sub
    
66.     arr = Range("a2:j" & lLastRow)
    
67. 
    
68.     arr(1, 1) = "gh"
    
69.     arr(1, 2) = "name"
    
70.     arr(1, 3) = "password"
    
71.     arr(1, 8) = "生产计划"
    
72. 
    
73.     Randomize (2013)
    
74. 
    
75.     With AdoRst
    
76.         For i = LBound(arr) + 1 To UBound(arr)
    
77.             .AddNew
    
78.             For j = 1 To UBound(arr, 2)
    
79.                 .Fields(arr(1, j)).Value = arr(i, j)
    
80.             Next
    
81.             .Fields("id") = (Rnd(2013) * 65536 + 1) \ 1
    
82.             .Update
    
83.         Next
    
84.     End With
    
85.     Set AdoRst = Nothing
    
86.     MsgBox "用户更新完成", vbInformation + vbOKOnly
    
87. 
    
88. End1:
    
89.     Exit Sub
    
90. 
    
91. ErrCheck:
    
92.     MsgBox Err.Number & vbCrLf & _
    
93.            Err.Description, vbCritical
    
94.     Resume End1
    
95. End Sub
    
96. 
    
97. Sub 读取用户()
    
98. 
    
99.     If Not ConnectDatabase Then
    
100.         MsgBox strError, vbCritical
     
101.         Exit Sub
     
102.     End If
     
103. 
     
104.     On Error GoTo ErrCheck
     
105. 
     
106. 
     
107.     Dim lLastRow&
     
108.     Dim arr, strFields$
     
109. 
     
110.     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
     
111.     If lLastRow < 2 Then Exit Sub
     
112. 
     
113.     arr = Range("a2:j" & lLastRow)
     
114.     If llatrow > 2 Then Range("a3:j" & lLastRow).Value = ""
     
115.     arr(1, 1) = "gh"
     
116.     arr(1, 2) = "name"
     
117.     arr(1, 3) = "password"
     
118.     arr(1, 8) = "生产计划"
     
119. 
     
120.     arr = WorksheetFunction.Index(arr, 1, 0)
     
121.     strFields = Join(arr, ",")
     
122. 
     
123.     strSQL = "select "
     
124.     Range("a3").CopyFromRecordset AdoConn.Execute(strSQL & strFields & " from yftab")
     
125.     MsgBox "用户导入完成", vbInformation + vbOKOnly
     
126. 
     
127. End1:
     
128.     Set AdoRst = Nothing
     
129.     Exit Sub
     
130. 
     
131. ErrCheck:
     
132.     MsgBox Err.Number & vbCrLf & _
     
133.            Err.Description, vbCritical
     
134.     Resume End1
     
135. 
     
136. End Sub

复制代码

hwc2ycy

楼主，提个建议啊。
你的EXCEL表字段名与ACCESS表的设计最好是相同的。
另外在ACCESS的YFTAB中，列标题最好统一，不要又是中文又是英文的。

hwc2ycy

上面有点小错误，变量名有个写错了。

1. Option Explicit
   
2. Const adUseClient = 3
   
3. Const adModeShareDenyWrite = 8
   
4. Const adModeReadWrite = 3
   
5. 
   
6. Dim StrConn$, strSQL$
   
7. Dim AccessFile$, DataSource$
   
8. Dim strError$
   
9. Dim AdoConn As Object
   
10. Dim AdoRst As Object
    
11. 
    
12. 
    
13. Function ConnectDatabase() As Boolean
    
14.     AccessFile = "mg.mdb"
    
15.     DataSource = ThisWorkbook.Path & Application.PathSeparator & AccessFile
    
16. 
    
17.     StrConn = "Provider= Microsoft.Jet.OLEDB.4.0;" & _
    
18.               "Data Source=" & DataSource & ";"""
    
19. 
    
20.     If AdoConn Is Nothing Then
    
21.         Set AdoConn = CreateObject("ADODB.Connection")
    
22.         On Error GoTo ErrCheck
    
23.         With AdoConn
    
24.             .CommandTimeout = 5
    
25.             .ConnectionTimeout = 5
    
26.             .CursorLocation = adUseClient
    
27.             .Mode = adModeReadWrite    'adModeShareDenyWrite
    
28.             .ConnectionString = StrConn
    
29.             .Open
    
30.         End With
    
31.         ConnectDatabase = True
    
32.     Else
    
33.         ConnectDatabase = True
    
34.     End If
    
35.     Exit Function
    
36. 
    
37. End1:
    
38.     Set AdoConn = Nothing
    
39.     Exit Function
    
40. 
    
41. ErrCheck:
    
42. 
    
43.     strError = Err.Number & vbCrLf & _
    
44.                Err.Description
    
45.     Resume End1
    
46. End Function
    
47. 
    
48. Sub 用户更新()
    
49. 
    
50.     If Not ConnectDatabase Then
    
51.         MsgBox strError, vbCritical
    
52.         Exit Sub
    
53.     End If
    
54. 
    
55.     strSQL = "delete from yftab"
    
56.     AdoConn.Execute strSQL
    
57. 
    
58.     Set AdoRst = CreateObject("ADODB.Recordset")
    
59.     AdoRst.Open "yftab", AdoConn, 2, 3    'adOpenDynamic, adLockOptimistic
    
60. 
    
61.     Dim lLastRow&, i&, j&
    
62.     Dim arr
    
63. 
    
64.     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    
65.     If lLastRow < 3 Then Exit Sub
    
66.     arr = Range("a2:j" & lLastRow)
    
67. 
    
68.     arr(1, 1) = "gh"
    
69.     arr(1, 2) = "name"
    
70.     arr(1, 3) = "password"
    
71.     arr(1, 8) = "生产计划"
    
72. 
    
73.     Randomize (2013)
    
74. 
    
75.     With AdoRst
    
76.         For i = LBound(arr) + 1 To UBound(arr)
    
77.             .AddNew
    
78.             For j = 1 To UBound(arr, 2)
    
79.                 .Fields(arr(1, j)).Value = arr(i, j)
    
80.             Next
    
81.             .Fields("id") = (Rnd(2013) * 65536 + 1) \ 1
    
82.             .Update
    
83.         Next
    
84.     End With
    
85.     Set AdoRst = Nothing
    
86.     MsgBox "用户更新完成", vbInformation + vbOKOnly
    
87. 
    
88. End1:
    
89.     Exit Sub
    
90. 
    
91. ErrCheck:
    
92.     MsgBox Err.Number & vbCrLf & _
    
93.            Err.Description, vbCritical
    
94.     Resume End1
    
95. End Sub
    
96. 
    
97. Sub 读取用户()
    
98. 
    
99.     If Not ConnectDatabase Then
    
100.         MsgBox strError, vbCritical
     
101.         Exit Sub
     
102.     End If
     
103. 
     
104.     On Error GoTo ErrCheck
     
105. 
     
106. 
     
107.     Dim lLastRow&
     
108.     Dim arr, strFields$
     
109. 
     
110.     lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
     
111.     If lLastRow < 2 Then Exit Sub
     
112. 
     
113.     arr = Range("a2:j" & lLastRow)
     
114.     If lLastRow > 2 Then Range("a3:j" & lLastRow).Value = ""
     
115.     arr(1, 1) = "gh"
     
116.     arr(1, 2) = "name"
     
117.     arr(1, 3) = "password"
     
118.     arr(1, 8) = "生产计划"
     
119. 
     
120.     arr = WorksheetFunction.Index(arr, 1, 0)
     
121.     strFields = Join(arr, ",")
     
122. 
     
123.     strSQL = "select "
     
124.     Range("a3").CopyFromRecordset AdoConn.Execute(strSQL & strFields & " from yftab")
     
125.     MsgBox "用户导入完成", vbInformation + vbOKOnly
     
126. 
     
127. End1:
     
128.     Set AdoRst = Nothing
     
129.     Exit Sub
     
130. 
     
131. ErrCheck:
     
132.     MsgBox Err.Number & vbCrLf & _
     
133.            Err.Description, vbCritical
     
134.     Resume End1
     
135. 
     
136. End Sub
     

复制代码