[已解决]跨表不重复

张雄友

跨表不重复取值。

最佳答案

月排行榜 / 总排行榜

zjdh

2014-6-11 21:34

跨表不重复.rar (38.42 KB, 下载次数: 23)

2014-6-11 21:34 上传

点击文件名下载附件

跳转到最佳答案楼层

zjdh

跨表不重复.rar (38.42 KB, 下载次数: 23)

2014-6-11 21:34 上传

点击文件名下载附件

张雄友

zjdh 发表于 2014-6-11 21:34

你这种选择文件夹的方式我第一次见到，很好用。如果是提取重复的呢？

zjdh

1. Sub 用选择文件夹的方式提取A列重复值()
   
2.     [A1:A65536].ClearContents
   
3.     Dim sh As Worksheet, arr, d As Object, i&, r&, MyPath$
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set d1 = CreateObject("Scripting.Dictionary")
   
6.     Set Fold = CreateObject("shell.application").BrowseForFolder(0, "请选择存放数据的文件夹：", 0, "")
   
7.     If Fold Is Nothing Then Exit Sub
   
8.     Fpath = Fold.Items.Item.Path
   
9.     Application.ScreenUpdating = False
   
10.     If Fpath > "" Then
    
11.         ReDim arr(1 To 2, 1 To 1)
    
12.         MyPath = Fpath & ""
    
13.         Myfile = Dir(MyPath & "\*.xls")
    
14.         Do Until Myfile = ""
    
15.             If Myfile <> ThisWorkbook.Name Then
    
16.                 Set wk = Workbooks.Open(MyPath & "" & Myfile)
    
17.                 For Each sh In Sheets
    
18.                     If Application.CountA(sh.UsedRange) Then
    
19.                         arr = sh.Range("A1:A" & sh.Range("A65536").End(3).Row)
    
20.                         For i = 1 To UBound(arr)
    
21.                             If Not d.exists(arr(i, 1)) Then
    
22.                                 d(arr(i, 1)) = ""
    
23.                             Else
    
24.                                 If arr(i, 1) <> "" Then d1(arr(i, 1)) = ""
    
25.                             End If
    
26.                         Next
    
27.                     End If
    
28.                 Next
    
29.                 wk.Close False
    
30.             End If
    
31.             Myfile = Dir
    
32.         Loop
    
33.     End If
    
34.     [A1].Resize(d1.Count, 1) = Application.Transpose(d1.KEYS)
    
35.     Application.ScreenUpdating = True
    
36. End Sub

复制代码