新手求如何筛选数据后另存到新工作簿

唏嘘的白羊座

求助：
附件工作簿一共2个工作表。
要求按照“名单”表中的A1列对“数据”表A1列进行筛选，筛选出同一个类型的数据保存至新的工作簿，
其中新工作簿文件名为“名单”表的D列对应名称，第一行抬头与“数据”表保持一致，求解，谢谢！

唏嘘的白羊座

需要做个循环，直至名单表A列为空

auloveagbb

记号一下，下班后看看！

auloveagbb

见附件，基本满足，数据量大，需要时间。

bosao

auloveagbb 发表于 2016-11-10 23:16
见附件，基本满足，数据量大，需要时间。

为什么是编译错误要求对象呢？发生在Set m = 0

chxw68

1. Sub test()
   
2.   Dim r&, i&
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   With Worksheets("名单")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     arr = .Range("a2:d" & r)
    
12.     For i = 1 To UBound(arr)
    
13.       d(arr(i, 1)) = arr(i, 4)
    
14.     Next
    
15.   End With
    
16.   With Worksheets("数据")
    
17.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
18.     arr = .Range("a1:a" & r)
    
19.     For i = 2 To UBound(arr)
    
20.       If d.exists(arr(i, 1)) Then
    
21.         xm = d(arr(i, 1))
    
22.         If Not d1.exists(xm) Then
    
23.           Set d1(xm) = .Range("a1:i1")
    
24.         End If
    
25.         Set d1(xm) = Union(d1(xm), .Cells(i, 1).Resize(1, 9))
    
26.       End If
    
27.     Next
    
28.   End With
    
29.   Application.SheetsInNewWorkbook = 1
    
30.   For Each aa In d1.keys
    
31.     Set wb = Workbooks.Add
    
32.     With wb
    
33.       With .Worksheets(1)
    
34.         d1(aa).Copy .Range("a1")
    
35.       End With
    
36.       .SaveAs Filename:=ThisWorkbook.Path & "" & aa
    
37.       .Close False
    
38.     End With
    
39.   Next
    
40. End Sub
    

复制代码

chxw68

拆分了43个文件，共用时27秒。

zyy19880218

不错，这方面的代码不尽相同