提取不重复值

95328

请高手帮小菜写一段VB，在页2的A列提取页1的A列中不重复的值。 提取不重复值.rar (1.9 KB, 下载次数: 452)

2013-1-13 15:31 上传

点击文件名下载附件

感谢

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, d
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Sheet2.Activate
   
5. Arr = Sheet1.[a1].CurrentRegion
   
6. For i = 1 To UBound(Arr)
   
7.     d(Arr(i, 1)) = ""
   
8. Next
   
9. [a1].Resize(d.Count) = Application.Transpose(d.keys)
   
10. End Sub
    

复制代码

蓝桥玄霜

请见附件。

95328

蓝桥玄霜 发表于 2013-1-13 15:43
请见附件。

谢谢老师。好用。老师，再问个问题，如果提取的区域是某一部份区域，如：A1：E8，需要怎样修改那段VB？

hopeson2010

1. Sub ek_sky()
   
2.     Dim a As Variant, r1 As Long, c1 As Byte, b() As Variant
   
3.     Dim d As Object, j As Long
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     With Sheets("sheet1")
   
6.         a = .Range("A1:E8").Value
   
7.     End With
   
8.     For r1 = 1 To UBound(a)
   
9.         For c1 = 1 To UBound(a, 2)
   
10.             If a(r1, c1) <> "" Then
    
11.                 If Not d.exists(a(r1, c1)) Then
    
12.                     j = j + 1
    
13.                     d.Add a(r1, c1), j
    
14.                     ReDim Preserve b(1 To 1, 1 To j)
    
15.                     b(1, j) = a(r1, c1)
    
16.                 End If
    
17.             End If
    
18.         Next c1
    
19.     Next r1
    
20.     With Sheets("sheet2")
    
21.         .Range("A:A").ClearContents
    
22.         .Range("A1").Resize(j) = WorksheetFunction.Transpose(b)
    
23.     End With
    
24.     Set a = Nothing: Set d = Nothing
    
25. End Sub

复制代码

95328

hopeson2010 发表于 2013-1-13 16:25

感谢老师..

蓝桥玄霜

1. Sub lqxs()
   
2. Dim d, rng As Range, cel As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Sheet2.Activate
   
5. Set rng = Sheet1.[a1:e8]
   
6. For Each cel In rng
   
7.     If cel.Value <> "" Then d(cel.Value) = ""
   
8. Next
   
9. [a1].Resize(d.Count) = Application.Transpose(d.keys)
   
10. End Sub
    

复制代码

95328

蓝桥玄霜 发表于 2013-1-13 17:40

感谢老师。。。。

CJXUEHAO

蓝桥玄霜 发表于 2013-1-13 17:40

老师，有没有办法写段代码，如果破坏了宏密码，则自动删除所有代码？

jackbauerctu

蓝桥玄霜 发表于 2013-1-13 17:40

老师您好，如果附件在有些变化，请在老师指点一下