筛选一个文件夹下所有工作簿中共有的数据

七月安

         一个文件夹下有8个工作簿，里面都是站点号、CM1、CM2三列数据。因为有的数据不能使用（已被剔除），所以每个工作簿中的数据有多有少（简单说就是行数不一样）。我想把8个工作簿中共有的站点对应的数据保留下来，其余的剔除。比如说对于99999站点，7个工作簿中都有这个站点的数据，有1个工作簿没有，就把其他7个的99999站点数据也全部剔除。

        我实在没有头绪，手动筛选工作量有点大也容易出错，想请各位老师指导一下，谢谢！ 站点.rar (487.46 KB, 下载次数: 4)

2018-7-9 17:04 上传

点击文件名下载附件

LMY123

提取重复8次的数据

liulang0808

1. Sub 按钮1_Click()
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set df = CreateObject("scripting.dictionary")
   
5.     Application.ScreenUpdating = False
   
6.     For Each f In fso.getfolder(ThisWorkbook.Path).Files
   
7.         If (InStr(f.Name, "剔除不完全数据") + InStr(f.Name, "$")) = 0 Then
   
8.             df(f.Name) = ""
   
9.             With Workbooks.Open(f)
   
10.                 arr = .Sheets(1).UsedRange
    
11.                 For j = 2 To UBound(arr)
    
12.                     d(arr(j, 1)) = 1 + d(arr(j, 1))
    
13.                 Next j
    
14.             End With
    
15.         End If
    
16.     Next f
    
17.     For j = 0 To df.Count - 1
    
18.         With Workbooks(df.keys()(j))
    
19.             arr = .Sheets(1).UsedRange
    
20.             a = 2
    
21.             For i = 2 To UBound(arr)
    
22.                 If d(arr(i, 1)) = df.Count Then
    
23.                     arr(a, 1) = arr(i, 1)
    
24.                     arr(a, 2) = arr(i, 2)
    
25.                     arr(a, 3) = arr(i, 3)
    
26.                     a = a + 1
    
27.                 End If
    
28.             Next i
    
29.             .Sheets(1).UsedRange.ClearContents
    
30.             .Sheets(1).[a1].Resize(a - 1, 3) = arr
    
31.             .Save
    
32.             .Close False
    
33.         End With
    
34.     Next j
    
35.     Application.ScreenUpdating = True
    
36. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。。。

七月安

liulang0808 发表于 2018-7-9 18:48
附件内容供参考。。。。。。

谢谢老师，非常感谢！