同一文件夹下依次打开工作簿选择指定内容新建文件夹及工作簿

革力

    各位老师，需要把名称为‘数据’文件夹里的工作簿依次打开，每一个打开的工作簿里，筛选 H列 “镇（街道）名称”里，幸福镇的数据新建一个工作簿，工作簿名称不变，新建一个“幸福镇”文件夹，把新的所有幸福镇的工作簿放入该文件夹内，其他镇也是如此，谢了

shiruiqiang

练手，挑战一下。
也是对自己的一次综合训练。

1、文件夹在表下。
2、因复制名称重复，名称稍有点变化

shiruiqiang

====练手====

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.25
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim arr, brr
   
5.     Dim tm: tm = Timer
   
6.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     On Error Resume Next
   
9.     p = ThisWorkbook.Path & ""
   
10.     p1 = p & "数据"
    
11.     For Each f In Fso.GetFolder(p1).Files
    
12.         If f.Name Like "*.xlsx" Then
    
13.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
14.                 d.RemoveAll
    
15.                 fn = Fso.GetBaseName(f)
    
16.                 Set wb = Workbooks.Open(f, 0)
    
17.                 Set sht = wb.Sheets(1)
    
18.                 arr = sht.UsedRange
    
19.                 For i = 3 To UBound(arr)
    
20.                     s = arr(i, 8)
    
21.                     If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
22.                     d(s)(i) = i
    
23.                 Next
    
24.                 For Each k In d.keys
    
25.                     m = 0
    
26.                     p2 = p & k & "数据"
    
27.                     If Not Fso.FolderExists(p2) Then Fso.CreateFolder p2
    
28.                     sht.Copy
    
29.                     Set ws = ActiveWorkbook
    
30.                     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
    
31.                     With ws.Sheets(1)
    
32.                         .Name = k
    
33.                         .DrawingObjects.Delete
    
34.                         .UsedRange.Offset(2 + d(k).Count).Clear
    
35.                         For Each kk In d(k).keys
    
36.                             m = m + 1
    
37.                             For j = 1 To UBound(arr, 2)
    
38.                                 brr(m, j) = arr(kk, j)
    
39.                             Next
    
40.                         Next
    
41.                         .[a3].Resize(m, UBound(brr, 2)) = brr
    
42.                     End With
    
43.                     ws.SaveAs p2 & fn & "-" & k
    
44.                     ws.Close
    
45.                 Next
    
46.                 wb.Close False
    
47.             End If
    
48.         End If
    
49.     Next f
    
50.     Application.ScreenUpdating = True
    
51.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
52. End Sub
    

复制代码

ykcbf1100

附件供参考。。。