查找删除与比较提取

SCWYZJ

求助：怎样实现这俩个效果，因工作需要，想提高效率，但又不会VBa，所以此请教老师们，帮我一下！不胜感激！

lsc900707

在职信息更新的：

1. Sub gj23w98()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     arr = Sheet2.[a1].CurrentRegion
   
4.     For i = 2 To UBound(arr)
   
5.         d(arr(i, 1)) = i
   
6.     Next
   
7.     brr = [a1].CurrentRegion
   
8.     ReDim crr(1 To UBound(brr), 1 To UBound(brr, 2))
   
9.     For i = 2 To UBound(brr)
   
10.         If Not d.exists(brr(i, 1)) Then
    
11.             m = m + 1
    
12.             For j = 1 To UBound(brr, 2)
    
13.                 crr(m, j) = brr(i, j)
    
14.             Next
    
15.         End If
    
16.     Next
    
17.     [a1].CurrentRegion.Offset(1).ClearContents
    
18.     [a2].Resize(m, UBound(crr, 2)) = crr
    
19. End Sub

复制代码

lsc900707

在职信息更新附件供参考：

lsc900707

提取外宿名单的：

1. Sub gj23w98b()
   
2.     Dim crr(1 To 100, 1 To 2)
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     r = Cells(Rows.Count, 1).End(3).Row
   
5.     arr = Range("c3:d" & r)
   
6.     For i = 1 To UBound(arr)
   
7.         d(arr(i, 1)) = i
   
8.     Next
   
9.     brr = Range("a3:b" & r)
   
10.     For i = 1 To UBound(brr)
    
11.         If Not d.exists(brr(i, 1)) Then
    
12.             m = m + 1
    
13.             For j = 1 To 2
    
14.                 crr(m, j) = brr(i, j)
    
15.             Next
    
16.         End If
    
17.     Next
    
18.     Range("e3:f" & Rows.Count).ClearContents
    
19.     [e3].Resize(m, 2) = crr
    
20. End Sub

复制代码

lsc900707

提取外宿名单附件供测试：

SCWYZJ

lsc900707l老师真是大神啊！谢谢你，完全符合我的要求。要是能稍加点注释就好了，方便学习理解！能不能麻烦老师在帮我看看这的呢？我在网上找了好久都没有找到这类实例教程，只好在这麻烦下老师你了，谢谢！

blackttea1

学习啦谢谢