[已解决]VBA按同类拆分成工作表、工作薄

龙送农

zjdh 发表于 2015-8-31 19:32

老师：如果只要分解成独立的工作簿，代码如何精减？

yjwdjfqb

zjdh 发表于 2015-8-31 19:32

这样怎么执行不成功呀，老师，请指教下，谢谢老师了!

zjdh

Sub 拆分()
    On Error Resume Next
    Set Rng = Application.InputBox("请选择拆分的字段", "选择", , , , , , 8)
    If Rng Is Nothing Then Exit Sub
    B = MsgBox("是否拆成独立工作簿？", 4 + 32 + 256, "设定")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For I = Sheets.Count To 2 Step -1
        Sheets(I).Delete
    Next
    Set D = CreateObject("scripting.dictionary")
    ARR = Range("A2").CurrentRegion
    CL = Rng.Column
    For I = 3 To UBound(ARR)
        If Not D.exists(ARR(I, CL)) Then
            D(ARR(I, CL)) = I
        Else
            D(ARR(I, CL)) = D(ARR(I, CL)) & "," & I
        End If
    Next
    K = D.KEYS
    For I = 0 To UBound(K)
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = K(I)
        ThisWorkbook.Sheets(1).Range("A1:I2").Copy ActiveSheet.Range("A1")
        W = Split(D(K(I)), ",")
        For J = 0 To UBound(W)
            ThisWorkbook.Sheets(1).Rows(W(J)).Copy ActiveSheet.Range("A65536").End(3)(2)
        Next
        ActiveSheet.Columns("A:I").Columns.AutoFit
        If B = 6 Then
            Sheets(K(I)).Copy
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & K(I) & ".xls"
            ActiveWorkbook.Close
            Sheets(K(I)).Delete
        End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "拆分完成！"
End Sub

zjdh

龙送农 发表于 2015-9-1 16:11
老师：如果只要分解成独立的工作簿，代码如何精减？

删减不了多少，还不如留着另一个功能。

zjdh

安全网 发表于 2015-9-1 13:55
是否可以变成可以加载的宏通用

2楼不是有介绍通用工具了吗？

龙送农

zjdh 发表于 2015-9-1 19:19
删减不了多少，还不如留着另一个功能。

我有一个表，只需要分解成独立的工作簿的这个功能。想借您写的这个代码来用，麻烦您老师精简，先谢了！

yjwdjfqb

zjdh 发表于 2015-9-1 19:18
Sub 拆分()
    On Error Resume Next
    Set Rng = Application.InputBox("请选择拆分的字段", "选择", ...

谢谢老师的耐心解答！

安全网

zjdh 发表于 2015-9-1 19:24
2楼不是有介绍通用工具了吗？

如果是当前打开的工作薄要拆分，二楼的就需要重新选择，这样操作起来因为当前的工作设置了密码就需要重新输入密码才行

zjdh

龙送农 发表于 2015-9-1 20:03
我有一个表，只需要分解成独立的工作簿的这个功能。想借您写的这个代码来用，麻烦您老师精简，先谢了！{: ...

Sub 拆分()
    On Error Resume Next
    Set Rng = Application.InputBox("请选择拆分的字段", "选择", , , , , , 8)
    If Rng Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set D = CreateObject("scripting.dictionary")
    ARR = Range("A2").CurrentRegion
    CL = Rng.Column
    For I = 3 To UBound(ARR)
        If Not D.exists(ARR(I, CL)) Then
            D(ARR(I, CL)) = I
        Else
            D(ARR(I, CL)) = D(ARR(I, CL)) & "," & I
        End If
    Next
    K = D.KEYS
    For I = 0 To UBound(K)
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = K(I)
        ThisWorkbook.Sheets(1).Range("A1:I2").Copy ActiveSheet.Range("A1")
        W = Split(D(K(I)), ",")
        For J = 0 To UBound(W)
            ThisWorkbook.Sheets(1).Rows(W(J)).Copy ActiveSheet.Range("A65536").End(3)(2)
        Next
        ActiveSheet.Columns("A:I").Columns.AutoFit
        Sheets(K(I)).Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & K(I) & ".xls"
        ActiveWorkbook.Close
        Sheets(K(I)).Delete
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "拆分完成！"
End Sub

龙送农

zjdh 发表于 2015-9-1 21:40
Sub 拆分()
    On Error Resume Next
    Set Rng = Application.InputBox("请选择拆分的字段", "选择 ...

谢谢老师的耐心指教！