Sheet1里的内容，按照部门快速制定分离表格

308896292

请大神请教，数据量大人工分离太耗时间

3190496160

Sub 拆分()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim arr, d As Object, k, lc%, rng As Range
    Dim rng2 As Range
    For Each sh In Sheets
        If sh.Index > 1 Then
            sh.Delete
        End If
    Next sh
    arr = Sheet1.[a1].CurrentRegion
    lc = UBound(arr, 2)
    Set rng = Sheet1.[a1].Resize(, lc)
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        If Not d.Exists(arr(i, 1)) Then
            Set d(arr(i, 1)) = Cells(i, 1).Resize(1, lc)
        Else
            Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, lc))
        End If
    Next
    k = d.Keys
    Application.SheetsInNewWorkbook = 1 '设置创建2个工作表
    FileName1 = ThisWorkbook.Path & "\" & ThisWorkbook.Name
    For i = 0 To UBound(k)
        Set sht = Worksheets.Add(after:=Sheets(Sheets.Count))
        rng.Copy sht.[a1]
        d.items()(i).Copy sht.[a2]
        sht.Name = k(i)
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "拆分结束"
End Sub

3190496160

表格制动分表格.rar (17.42 KB, 下载次数: 14)

2021-9-16 10:12 上传

点击文件名下载附件

jstsht

用易用宝或方方格子都有拆分工作表

jians0529

如图用数据透视表进行拆分。。
或者可以搜索论坛里面免费的易用宝。。

308896292

jians0529 发表于 2021-9-16 10:25
如图用数据透视表进行拆分。。
或者可以搜索论坛里面免费的易用宝。。

谢谢大神，能全部拆分出单独的表格吗

臧礼莉

来试试这个，效果很不错