根据条件筛选后拆成多个表格

ccyinger

请教各位大神，
如何将文件中进行“省份”筛选后，
将不同省份的所有内容生成一个新*xlsx，文件命名为该省份
附件中的代码是我网上找的拿来套用，但是他筛选后只提取一列数据，而我想要的是全部的内容，包括表头和格式以及公式,各位大神能否帮忙看下能否修改下代码，或者其他的VBA代码实现
非常感谢！

ccyinger

没人理我

sam-wang

請測試看看，謝謝
Sub test()
Dim Arr, i%, xD
Application.ScreenUpdating = False: Application.DisplayAlerts = False
Arr = Sheets(1).[a1].CurrentRegion
Set xD = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(Arr)
    If xD.exists(Arr(i, 4)) Then
        Set xD(Arr(i, 4)) = Union(xD(Arr(i, 4)), Rows(i))
    Else
        Set xD(Arr(i, 4)) = Union(Rows(1), Rows(i))
    End If
Next
For i = 0 To xD.Count - 1
    Workbooks.Add
    With ActiveWorkbook
        xD.items()(i).Copy .Sheets(1).[a1]
        .SaveAs ThisWorkbook.Path & "/" & xD.keys()(i)
        .Close
    End With
Next
MsgBox "完成"
Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

aidunsoft

点击进入B站表格拆分视频演示  https://www.bilibili.com/video/BV1rr4y117ri?t=0.0

ccyinger

sam-wang 发表于 2021-12-9 17:13
請測試看看，謝謝
Sub test()
Dim Arr, i%, xD

老师，能不能把公式一起复制进去呢，还有拆分原表格的sheet名称，感谢！！！

sam-wang

ccyinger 发表于 2021-12-10 09:04
老师，能不能把公式一起复制进去呢，感谢！！！

不好意思，需要等到晚上才能上傳檔案，謝謝

ccyinger

sam-wang 发表于 2021-12-10 12:10
不好意思，需要等到晚上才能上傳檔案，謝謝

好的，麻烦老师您了

sam-wang

ccyinger 发表于 2021-12-10 12:35
好的，麻烦老师您了

請測試看看，謝謝

ccyinger

sam-wang 发表于 2021-12-10 18:07
請測試看看，謝謝

老师，还是不行哦，拆分出来的还是只有数值，没有公式，能否帮忙再看看
对了，原表格的的Sheet名称能不能一起复制进去呢

sam-wang

ccyinger 发表于 2021-12-11 08:15
老师，还是不行哦，拆分出来的还是只有数值，没有公式，能否帮忙再看看
对了，原表格的的Sheet名称 ...

剛剛執行後的結果如照片與您原來需求對比，不知哪裡由遺漏的地方?
請再確認，謝謝