我要把一个工作表中的数据无重复添加到另一个工作表中

hqmtba

      我要把随时更新的“添加”工作表的数据添加到“明细”工作表中，先需要比较“添加”与“明细”中的数据，当“明细”中已有“添加”中相应数据就不添加，没有重复就添加到“明细”工作表已有数据下面。比如，“添加”中的“苗若兰、商老太、平四、马春花、张总管、王剑英”是“明细”中没有的，就要添加到“明细”中已有数据后面，而“钟兆英、钟兆能、南兰”是“明细”中已有的，就不要重复添加。请热心的老师帮忙，谢谢！ 员工学历.rar (2.42 KB, 下载次数: 47)

2015-1-26 13:23 上传

点击文件名下载附件

Vicel

1. Sub test()
   
2.     Dim ar, i%
   
3.     With Sheets("添加")
   
4.         ar = .Range("A2:B" & .[A65536].End(xlUp).Row)
   
5.     End With
   
6.     With Sheets("明细")
   
7.         For i = 1 To UBound(ar)
   
8.             If IsError(Application.Match(ar(i, 1), .Columns("A"), 0)) Then
   
9.                 .[A65536].End(xlUp).Offset(1, 1) = ar(i, 2)
   
10.                 .[A65536].End(xlUp).Offset(1, 0) = ar(i, 1)
    
11.             End If
    
12.         Next i
    
13.     End With
    
14. End Sub

复制代码

员工学历.rar (8.53 KB, 下载次数: 132)

2015-1-26 13:38 上传

点击文件名下载附件

TomingTang

1. Sub 添加()
   
2.     Dim Arr, Brr, drow%, i%, j%, d, Crr(), k%
   
3.     k = 1
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Arr = Worksheets("添加").Range("a1").CurrentRegion
   
6.     With Worksheets("明细")
   
7.         drow = .Range("a65536").End(3).Row
   
8.         Brr = .Range("a2:b" & drow)
   
9.         For i = 1 To UBound(Arr)
   
10.             d(Brr(i, 1)) = ""
    
11.         Next
    
12.         ReDim Crr(1 To UBound(Arr), 1 To 2)
    
13.         For i = 2 To UBound(Arr)
    
14.             If Not d.exists(Arr(i, 1)) Then
    
15.                 Crr(k, 1) = Arr(i, 1): Crr(k, 2) = Arr(i, 2)
    
16.                 k = k + 1
    
17.             End If
    
18.         Next
    
19.         .Range("a" & drow + 1).Resize(k, 2) = Crr
    
20.     End With
    
21. End Sub
    
22. 
    

复制代码

TomingTang

字典轻松解决。

hqmtba

Vicel 发表于 2015-1-26 13:38

      哇，太感谢了，效率太高了！现在又有个新问题，因为添加了新数据后原有的顺序就乱了，现在我要在添加新数据之前，对“明细”中的原有数据按A列升序排序，然后再添加新数据。请指教，谢谢！

hqmtba

TomingTang 发表于 2015-1-26 13:42
字典轻松解决。

     谢谢您的代码，但是有个问题没解决，就是没有判断重复问题，不管“明细”中有没有该数据，都把“添加”的数据添加到了“明细”中。

Vicel

hqmtba 发表于 2015-1-26 13:49
哇，太感谢了，效率太高了！现在又有个新问题，因为添加了新数据后原有的顺序就乱了，现在我要在添 ...

怎么会是先排序再添加呢？
要排序的话，也是先添加后再重新排序吧

hqmtba

Vicel 发表于 2015-1-26 14:00
怎么会是先排序再添加呢？
要排序的话，也是先添加后再重新排序吧

是的，我糊涂了，还是您想得周到，当然先添加后排序好，有劳了！

Vicel

hqmtba 发表于 2015-1-26 14:03
是的，我糊涂了，还是您想得周到，当然先添加后排序好，有劳了！

1. Sub test()
   
2.     Dim ar, i%
   
3.     With Sheets("添加")
   
4.         ar = .Range("A2:B" & .[A65536].End(xlUp).Row)
   
5.     End With
   
6.     With Sheets("明细")
   
7.         For i = 1 To UBound(ar)
   
8.             If IsError(Application.Match(ar(i, 1), .Columns("A"), 0)) Then
   
9.                 .[A65536].End(xlUp).Offset(1, 1) = ar(i, 2)
   
10.                 .[A65536].End(xlUp).Offset(1, 0) = ar(i, 1)
    
11.             End If
    
12.         Next i
    
13.         .Columns("A:B").Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes
    
14.     End With
    
15. End Sub
    

复制代码

TomingTang

1. Sub 添加()
   
2.     Dim Arr, Brr, drow%, i%, j%, d, Crr(), k%
   
3.     k = 1
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Arr = Worksheets("添加").Range("a2:b" & Worksheets("添加").Range("a65536").End(3).Row)
   
6.     With Worksheets("明细")
   
7.         drow = .Range("a65536").End(3).Row
   
8.         Brr = .Range("a2:b" & drow)
   
9.         For i = 1 To UBound(Brr)
   
10.             d(Brr(i, 1)) = Brr(i, 2)
    
11.         Next
    
12.         ReDim Crr(1 To UBound(Arr), 1 To 2)
    
13.         For i = 1 To UBound(Arr)
    
14.             If Not d.exists(Arr(i, 1)) Then
    
15.                 Crr(k, 1) = Arr(i, 1): Crr(k, 2) = Arr(i, 2)
    
16.                 k = k + 1
    
17.             End If
    
18.         Next
    
19.         .Range("a" & drow + 1).Resize(k, 2) = Crr
    
20.     End With
    
21. End Sub
    
22. 
    

复制代码

某个写错了。现在改好了。我的程序运行速度比2楼，当量大时。 员工学历.zip (11.51 KB, 下载次数: 146)

2015-1-26 14:29 上传

点击文件名下载附件