提取不重复数据

yuanfangzhiyuan

各位大侠，如图1 所示，想把员工年薪汇总表要把前面月薪汇总表的人员按照部门和人名只要有个不相同的就筛选出来，如图2 所示，哪位大侠能帮助用VBA实现，万分感谢！附件如下 汇总数据.zip (82.02 KB, 下载次数: 161)

2016-8-5 22:57 上传

点击文件名下载附件

182197315

Sub 提取不重复人名()
Dim i%, k%, arr, brr, crr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
arr = Sheets(1).Range("A3:D" & Range("A65536").End(xlUp).Row)
For i = 1 To UBound(arr)
    d(arr(i, 3) & "-" & arr(i, 4)) = ""
Next
brr = Application.Transpose(d.keys)
ReDim crr(1 To UBound(brr), 1 To 2)
For k = 1 To d.Count
    crr(k, 1) = Split(brr(k, 1), "-")(0)
    crr(k, 2) = Split(brr(k, 1), "-")(1)
Next
Sheets(2).Range("C3").Resize(k, 2) = crr
End Sub

yuanfangzhiyuan

大侠，运行结果不对，求指教

yuanfangzhiyuan

182197315 发表于 2016-8-6 07:13
Sub 提取不重复人名()
Dim i%, k%, arr, brr, crr
Dim d As Object

大侠，可能是我没说清楚，我是想把部门和姓名作为筛选条件，把两个合起来作比较，只要有一个不同的就筛选出来复制到年度汇总表里面。

182197315

Sub 提取不重复人名()
Dim i%, k%, arr, brr, crr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
arr = Sheets(1).Range("A3:D" & Range("D65536").End(xlUp).Row)
For i = 1 To UBound(arr)
    d(arr(i, 3) & "-" & arr(i, 4)) = ""
Next
brr = Application.Transpose(d.keys)
ReDim crr(1 To UBound(brr), 1 To 2)
For k = 1 To d.Count
    crr(k, 1) = Split(brr(k, 1), "-")(0)
    crr(k, 2) = Split(brr(k, 1), "-")(1)
Next
Sheets(2).Range("C23").Resize(k, 2) = crr
End Sub

yuanfangzhiyuan

182197315 发表于 2016-8-6 07:48
Sub 提取不重复人名()
Dim i%, k%, arr, brr, crr
Dim d As Object

大神，这次是运行没有结果，能不能把你运行的附件发我看看，万分感谢！

yuanfangzhiyuan

182197315 发表于 2016-8-6 07:48
Sub 提取不重复人名()
Dim i%, k%, arr, brr, crr
Dim d As Object

大神，这个程序还是有问题Sheets(2).Range("C23").Resize(k, 2) = crr，这里我改成了Sheets(2).Range("C3").Resize(k, 2) = crr能运行出来，但是原始数据我再加几个人就提出不出来了，求赐教

182197315

使用arr = Sheets("员工薪酬月度汇总表").Range("A3:D" & Range("D65536").End(xlUp).Row).Value得到的arr只有”34行”，应该是39行，我不知道为什么。
程序应该是没有什么问题的，不知道是不是你的表格格式，结构方面设置有什么问题。

jiminyanyan

yuanfangzhiyuan 发表于 2016-8-6 08:32
大神，这个程序还是有问题Sheets(2).Range("C23").Resize(k, 2) = crr，这里我改成了Sheets(2).Range("C3 ...

1. 
   
2. Sub 提取不重复人名()
   
3.     Dim i%, k%, arr, brr, crr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Sheet1.Range("A3:D" & Sheet1.Range("D65536").End(xlUp).Row)
   
7.     For i = 1 To UBound(arr)
   
8.         d(arr(i, 3) & "-" & arr(i, 4)) = ""
   
9.     Next
   
10.     brr = Application.Transpose(d.keys)
    
11.     ReDim crr(1 To UBound(brr), 1 To 2)
    
12.     For k = 1 To d.Count
    
13.         crr(k, 1) = Split(brr(k, 1), "-")(0)
    
14.         crr(k, 2) = Split(brr(k, 1), "-")(1)
    
15.     Next
    
16.     Sheet2.Range("C3").Resize(UBound(crr), 2) = crr
    
17. End Sub

复制代码

182197315

原来是 arr = Sheet1.Range("A3:D" & Sheet1.Range("D65536").End(xlUp).Row)这一句少了红字部分，谢谢老师