怎样按指定列的名称拆分为多个工作簿，谢谢！

ztd123

怎样按指定列的名称拆分为多个工作簿，谢谢！ 表.rar (10.13 KB, 下载次数: 7)

2023-7-25 07:57 上传

点击文件名下载附件

liulang0808

Sub test()
    Set d = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    arr = [a1].CurrentRegion
    For j = 2 To UBound(arr)
        If d.exists(arr(j, 4)) Then
            Set d(arr(j, 4)) = Union(d(arr(j, 4)), Cells(j, 1))
        Else
            Set d(arr(j, 4)) = Union(Cells(j, 1), Cells(1, 1))
        End If
    Next j
    ActiveSheet.Copy
    With ActiveWorkbook
        For Each k In d.keys
            .Sheets(1).UsedRange.Clear
            d(k).EntireRow.Copy .Sheets(1).[a1]
            .SaveAs ThisWorkbook.Path & "\" & k & ".xlsx"
        Next k
        .Close
    End With
    Application.ScreenUpdating = True
End Sub

liulang0808

ttt725.zip (68.55 KB, 下载次数: 13)

2023-7-25 08:08 上传

点击文件名下载附件

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

ztd123

liulang0808 发表于 2023-7-25 08:08
附件内容供参考。。。。。。

太厉害了，真诚的谢谢版主达人！

ykcbf1100

参与一下。。。

ztd123

ykcbf1100 发表于 2023-7-25 08:14
参与一下。。。

也是特别棒，谢谢您ykcbf1100老师！