根据excel表数据更新有重复记录的数据库并插入数据库中不存在的记录

zhaogang1960

根据工作表批量更新Access数据库并向数据库添加不存在的记录时，通常可以使用AddNew、Update方法，或update 语句和insert into语句实现，后者详见：
根据工作表批量更新Access数据库并向数据库添加不存在的记录(不使用循环)
http://club.excelhome.net/thread-1023579-1-1.html
但如果数据库和工作表中都有重复信息，且希望按照它们出现的顺序分别更新不同的数据，上面不能直接使用两种方法，下面代码使用字典+Update方法实现向数据库中按顺序更新重复记录：

1. Sub updateaddRecords()
   
2.     Dim cnn As Object, rs As Object, SQL$
   
3.     Dim a, arr, i&, j&, l&, s$, k, t, d As Object
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = [a1].CurrentRegion '工作表数据区域写入数组
   
6.    
   
7. '    用字典记录每个姓名出现在工作表中的行号
   
8.     For i = 2 To UBound(arr)
   
9.         s = arr(i, 1) & Chr(9) & arr(i, 2)
   
10.         If Not d.Exists(s) Then
    
11.             d(s) = i
    
12.         Else
    
13.             d(s) = d(s) & "," & i
    
14.         End If
    
15.     Next
    
16.     k = d.keys '不重复的姓名信息
    
17.     t = d.items '不重复的姓名出现的行号
    
18.    
    
19.     Set cnn = CreateObject("adodb.connection")
    
20.     cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\test.accdb"
    
21.    
    
22. '    更新数据库中存在的数据
    
23.     For i = 0 To d.Count - 1
    
24.         a = Split(k(i), Chr(9)) '分离LastName、FirstName
    
25.         SQL = "select * from Sheet1 where LastName='" & a(0) & "' and  FirstName='" & a(1) & "'" '查询该人员在数据除中记录
    
26.         Set rs = CreateObject("adodb.Recordset")
    
27.         rs.Open SQL, cnn, 1, 3
    
28.         n = rs.RecordCount '记录数
    
29.         If n > 0 Then '如果有记录
    
30.             a = Split(t(i), ",") '分离该人员在工作表中出现的行号
    
31.             For j = 0 To UBound(a) '逐个行号
    
32.                 If j + 1 > n Then Exit For '如果工作表中该人员记录次序大于数据库中的记录数则退出循环
    
33.                 rs.Move j, 1 '把指针移动到该人员出现次序的位置
    
34.                 For l = 3 To 7 '逐列数据更新到数据库
    
35.                     rs.Fields(l - 1) = arr(a(j), l)
    
36.                 Next l
    
37.                 rs.Update '更新
    
38.             Next j
    
39.         End If
    
40.     Next i
    
41.    
    
42. '    下面是插入数据库中不存在的记录
    
43.     SQL = "select a.* from [Excel 12.0;Database=" & ThisWorkbook.FullName & "].[" & ActiveSheet.Name & "$" & [a1].CurrentRegion.Address(0, 0) _
    
44.         & "] a left join Sheet1 b on a.LastName=b.LastName and a.FirstName=b.FirstName  where b.LastName is null"
    
45.     Set rs = CreateObject("adodb.recordset")
    
46.     rs.Open SQL, cnn, 1, 3
    
47.     If rs.RecordCount Then
    
48.         SQL = "insert into Sheet1 " & SQL
    
49.         cnn.Execute SQL
    
50.         MsgBox rs.RecordCount & "行数据已经添加到数据库！", vbInformation
    
51.     Else
    
52.          MsgBox "工作表的数据数据库中已经存在。", vbInformation
    
53.     End If
    
54.    
    
55.     rs.Close
    
56.     cnn.Close
    
57.     Set rs = Nothing
    
58.     Set cnn = Nothing
    
59. End Sub
    

复制代码

将excel表中的数据更新到Access数据库中(有重复).rar (35.83 KB, 下载次数: 686)

2013-6-3 19:12 上传

点击文件名下载附件

该贴已经同步到 zhaogang1960的微博

zhaogang1960

2003代码基本相同，请看附件
将excel表中的数据更新到Access数据库中(有重复)2003.rar (31.99 KB, 下载次数: 356)

2013-6-3 19:53 上传

点击文件名下载附件

klmyyq

非常好，新颖

ugyun

谢谢赵刚老师分享，收藏了

联系谁

谢谢赵刚老师分享，收藏了

fwcuenao

好东西下载起

学生甲1

赵老师请帮我看一下，我这一段代码有什么问题，我这里显示不能更新。
Sub test()

    Dim Sql As String
    Set conn = CreateObject("adodb.connection")
    p = ThisWorkbook.Path & "\aa.xls"
    conn.Open "provider=microsoft.jet.oledb.4.0; extended properties=excel 8.0; data source=" & ThisWorkbook.FullName
    Sql = "update [excel 8.0; imex=0 database=" & p & "].[a$] a, [b$] b "
    Sql = Sql & "set a.重量=b.重量 where a.运单号=b.运单号"
    conn.Execute (Sql)‘这里出错，电脑提示：不能更新’（表达示）‘；字段不可更新。
    conn.Close
    Set conn = Nothing

End Sub

学生甲1

赵老师不用麻烦你了，我找到问题了，imex=0;这一句少了一个；号。
Sql = "update [excel 8.0; imex=0; database=" & p & "].[a$] a, [b$] b "

samon_xu

zhaogang1960 发表于 2013-6-3 19:53
2003代码基本相同，请看附件

谢谢分享

tiger2003

学习中，谢谢！