提取不重复的数据

c99328

请各位老师指教：求编一段VB，把页1的数据按要求提取不重复的最后出现的数据整行放在页2
Book1.rar (11.81 KB, 下载次数: 357)

2016-4-28 19:03 上传

点击文件名下载附件

扯淡子

1. Sub test()
   
2.     Dim i%, arr
   
3.     arr = Sheets(1).Range("d2:d" & Sheets(1).Range("d65536").End(xlUp).Row)
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     For i = 1 To UBound(arr)
   
6.         dic(arr(i, 1)) = ""
   
7.     Next
   
8.     Sheets(2).Range("d2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys)
   
9. End Sub

复制代码

c99328

扯淡子 发表于 2016-4-28 19:55

老师，我要的效果不只D列提取，还要D列的值的最后整行都提取到页2

zax010

Sub zz()
    Dim d, ar
    Set d = CreateObject("Scripting.Dictionary")
    ar = Sheet1.Range("A1").CurrentRegion
    For i = 2 To UBound(ar)
        d(ar(i, 4)) = i
    Next
    With Sheet2
        For i = 2 To .[d65536].End(3).Row
            .Cells(i, 1).Resize(1, 11) = Application.Index(ar, d("" & .Cells(i, 4).Value))
        Next
    End With
End Sub

zax010

>>>>>>>>>>>>>>>>>>>



Bookb1.rar (13.68 KB, 下载次数: 294)

2016-4-28 21:02 上传

点击文件名下载附件

YZC51

请测试
去重.rar (18.91 KB, 下载次数: 354)

2016-4-28 22:55 上传

点击文件名下载附件

c99328

zax010 发表于 2016-4-28 21:02
Sub zz()
    Dim d, ar
    Set d = CreateObject("Scripting.Dictionary")

感谢老师的解答。就是要这个效果。但这个效果能不能一键生成？就是二楼的老师提取D列不重复的值结合您的按D列的值读取其它选项这两部份撮合成一键完成。请老师有时间帮我解答。感谢。。。

c99328

YZC51 发表于 2016-4-28 22:55
请测试

感谢帮忙解答。这个效果不是我想要的。

YZC51

这样呢？

1. Sub zz()
   
2.     Dim d, ar
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.    
   
5.     Sheet1.[D:D].Copy [D1]
   
6.     Columns(4).RemoveDuplicates 1 'array(1,2,3,5)
   
7. 
   
8.     ar = Sheet1.Range("A1").CurrentRegion
   
9.     For i = 2 To UBound(ar)
   
10.         d(ar(i, 4)) = i
    
11.     Next
    
12.     With Sheet2
    
13.         For i = 2 To .[d65536].End(3).Row
    
14.             .Cells(i, 1).Resize(1, 11) = Application.Index(ar, d("" & .Cells(i, 4).Value))
    
15.         Next
    
16.     End With
    
17. End Sub
    

复制代码

YZC51

再简化！

1. Sub zz1()
   
2.     [A:K] = ""
   
3.     Sheet1.[A:K].Copy [A1]
   
4.     Columns(4).RemoveDuplicates 1
   
5. End Sub

复制代码