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

革力

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

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, f, strFileName$, p$, vKey, strFolder$, dic As Object, Rng As Range
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")

    p = ThisWorkbook.Path & "\"
    For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(p & "数据\").Files
        If f.Name Like "*.xlsx" Then
            With GetObject(f)
                dic.RemoveAll
                With .Sheets(1).[A1].CurrentRegion
                    ar = .Value
                    Set Rng = .Range("A1:A2").Resize(, UBound(ar, 2))
                    For i = 3 To UBound(ar)
                        vKey = ar(i, 8) & "数据"
                        If Not dic.exists(vKey) Then
                            Set dic(vKey) = Rng
                        End If
                        Set dic(vKey) = Union(dic(vKey), .Cells(i, 1).Resize(, UBound(ar, 2)))
                    Next
                End With
                For Each vKey In dic.keys
                    strFolder = p & vKey & "\"
                    If Dir(strFolder, vbDirectory) = "" Then MkDir strFolder
                    strFileName = strFolder & vKey & "-" & f.Name
                    With Workbooks.Add
                        With .Sheets(1)
                            dic(vKey).Copy
                            .Cells(1, 1).PasteSpecial xlPasteColumnWidths
                            dic(vKey).Copy .Cells(1, 1)
                        End With
                        .SaveAs strFileName
                        .Close
                    End With
                Next
                .Close False
            End With
        End If
    Next
   
    Set Rng = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

革力

gwjkkkkk 发表于 2023-4-13 21:24
请参考附件。。。

多谢

革力

gwjkkkkk 发表于 2023-4-13 21:24
请参考附件。。。

老师你好，为啥当我这个数据有十来万行时，反应很慢，而且总是出错，运行不了

革力

革力 发表于 2023-5-4 14:42
老师你好，为啥当我这个数据有十来万行时，反应很慢，而且总是出错，运行不了

还有一个问题，在新工作簿保存之前，我想在新工作簿中删除一列，比如删除第8列，应该如何修改代码

ykcbf1100

革力 发表于 2023-5-4 14:42
老师你好，为啥当我这个数据有十来万行时，反应很慢，而且总是出错，运行不了

2楼老师的代码应该没啥问题，文件多时，打开工作簿和保存工作簿都是需要时间的。
你找找自己的原因吧。

革力

ykcbf1100 发表于 2023-5-4 14:50
2楼老师的代码应该没啥问题，文件多时，打开工作簿和保存工作簿都是需要时间的。
你找找自己的原因吧。
...

老师，你好，我知道二楼老师的代码没问题，当我数据几千行，运行速度很快，当我一万行以上时，运行特别慢，现在我的数据经常有几万十来万行的情况，应该怎么修改，或者有没有其他的好方法

革力

gwjkkkkk 发表于 2023-4-13 21:24
请参考附件。。。

老师好，为啥最近这个代码运行不了

limonet

翻出来是想着一键新建所有文件夹。结果因为要新建工作簿，还是要循环，干脆就一起写了，关键字：distinct+where