追加不重复记录

同心自相知

按身份证号码判断工资表格的记录在库中是否存在，若不存在则追加该员工资料

zhaogang1960

ADO法请参考：

1. Sub Macro1()
   
2.     Dim cnn As Object, rs As Object, SQL$
   
3.     Set cnn = CreateObject("adodb.connection")
   
4.     Set rs = CreateObject("adodb.recordset")
   
5.     cnn.Open "provider=Microsoft.ACE.OLEDB.12.0;extended properties=excel 12.0;data source=" & ThisWorkbook.Path & "\库.xls"
   
6.     SQL = "select a.* from [Excel 8.0;Database=" & ThisWorkbook.FullName & "].[工资$A2:F" & [a65536].End(xlUp).Row & _
   
7.         "] a left join [资料$A2:F] b on a.身份证号码=b.身份证号码 where b.身份证号码 is null"
   
8.     rs.Open SQL, cnn, 1, 3
   
9.     If rs.RecordCount > 0 Then '有记录
   
10.         SQL = "insert into [资料$A2:F] select 身份证号码,姓名,工组,工资卡号,联系电话号码,地址 as 联系地址 from [Excel 8.0;Database=" & ThisWorkbook.FullName & "].[工资$A2:F" & [a65536].End(xlUp).Row & "]" '添加记录
    
11.         cnn.Execute SQL '执行
    
12.         MsgBox "该记录已添加到库工作簿资料工作表。", vbInformation, "提示"
    
13.     Else
    
14.         MsgBox "该记录库工作簿资料工作表已经存在。", vbInformation, "提示"
    
15.     End If
    
16.     rs.Close
    
17.     cnn.Close
    
18.     Set rs = Nothing
    
19.     Set cnn = Nothing
    
20. End Sub

复制代码

zhaogang1960

请注意，在库工作簿资料工作表手工编辑后，请使用删除行方式删除内容，否则程序会认为有数据，请看附件
重复.rar (10.68 KB, 下载次数: 116)

2012-10-6 13:50 上传

点击文件名下载附件

zhaogang1960

常规法——打开工作簿比较，数组写数据：

1. Sub 常规法()
   
2.     Dim arr, brr, i&, j&, m&, d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     arr = Range("A1:F" & Range("A65536").End(xlUp).Row)
   
6.     With Workbooks.Open(ThisWorkbook.Path & "\库.xls")
   
7.         With .Sheets("资料")
   
8.             brr = .Range("A1:F" & .Range("A65536").End(xlUp).Row)
   
9.             For i = 3 To UBound(brr)
   
10.                 d(brr(i, 1)) = ""
    
11.             Next
    
12.             For i = 3 To UBound(arr)
    
13.                 If Not d.Exists(arr(i, 3)) Then
    
14.                     m = m + 1
    
15.                     arr(m, 1) = arr(i, 3)
    
16.                     arr(m, 2) = arr(i, 1)
    
17.                     arr(m, 3) = arr(i, 2)
    
18.                     For j = 4 To 6
    
19.                         arr(m, j) = arr(i, j)
    
20.                     Next
    
21.                 End If
    
22.             Next
    
23.             If m Then .[a65536].End(xlUp).Offset(1).Resize(m, 6) = arr
    
24.         End With
    
25.         .Close True
    
26.     End With
    
27.     Application.ScreenUpdating = True
    
28.     If m Then
    
29.         MsgBox "该记录已添加到库工作簿资料工作表。", vbInformation, "提示"
    
30.     Else
    
31.         MsgBox "该记录库工作簿资料工作表已经存在。", vbInformation, "提示"
    
32.     End If
    
33. End Sub
    

复制代码

zhaogang1960

常规法需要把库工作簿资料工作表单元格设置为文本格式，请看附件
重复.rar (16.09 KB, 下载次数: 149)

2012-10-6 14:08 上传

点击文件名下载附件

同心自相知

zhaogang1960 发表于 2012-10-6 14:08
常规法需要把库工作簿资料工作表单元格设置为文本格式，请看附件

{:soso_e113:}太谢谢您了，您太强了

gongqiulin

好东东，收藏之！

dannywinxp

zhaogang1960 发表于 2012-10-6 14:06
常规法——打开工作簿比较，数组写数据：

我看了你写的常规法追加记录，之前有另一个大侠也给我写了一个追加记录的方法，不过总是无法实现追加。我把他给我的文件放上，你能改成用你的常规法来实现记录的追加吗？ 问题0903.rar (15.36 KB, 下载次数: 33)

2013-9-3 10:07 上传

点击文件名下载附件

zhaogang1960

dannywinxp 发表于 2013-9-3 10:09
我看了你写的常规法追加记录，之前有另一个大侠也给我写了一个追加记录的方法，不过总是无法实现追加。我 ...

每次仅追加一条记录，使用你原来的方法就可以，修改一条语句即可：
Sub 追加()
Dim xh, r1, m&, xb$, xm$
    xh = [b1].Value: xm = [b2].Value: xb = [b3].Value
    Set r1 = Sheet2.[b:b].Find(xh, , , 1)
    If r1 Is Nothing Then
'        m = [a65536].End(xlUp).Row + 1
        With Sheet2
            m = .[a65536].End(xlUp).Row + 1
            .Cells(m, 1) = Split(xm, "班")(0) & "班"
            .Cells(m, 2) = xh
        
            .Cells(m, 3) = xm
            .Cells(m, 4) = xb
            MsgBox "已保存。"
        End With
    Else
        MsgBox "存在相同记录号，请使用保存记录按钮"
    End If
End Sub

dannywinxp

zhaogang1960 发表于 2013-9-3 11:59
每次仅追加一条记录，使用你原来的方法就可以，修改一条语句即可：
Sub 追加()
Dim xh, r1, m&, xb$, x ...

神，太神了！问题完全解决了。我烦了一整个晚上，好找不到解决的方法，你一句话解决了所有的问题。