[已解决]求工作簿中总表拆分多工作表VBA代码

ligh1298 · 发表于 2013-5-9 22:17

求工作簿中总表拆分多工作表VBA代码,要求在附件中，非常感谢！

最佳答案

hwc2ycy

2013-5-9 23:47

Sub 拆分()
Dim arr, i As Long, key1
Dim objDic As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
arr = Range("a1").CurrentRegion
Set objDic = CreateObject("scripting.dictionary")
For i = LBound(arr) + 1 To UBound(arr)
objDic(arr(i, 4)) = ""
Next
With Worksheets("总表")
For Each key1 In objDic.keys
.Range("a1").AutoFilter 4, key1
If Len(Worksheets(key1).Name) = 0 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = key1
End If
.Range("a1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Worksheets(key1).Range("a1")
Next
.Range("a1").AutoFilter
.Activate
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
MsgBox "表格拆分完成", vbInformation
End Sub

复制代码

hwc2ycy · 发表于 2013-5-9 23:47

Sub 拆分()
Dim arr, i As Long, key1
Dim objDic As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
arr = Range("a1").CurrentRegion
Set objDic = CreateObject("scripting.dictionary")
For i = LBound(arr) + 1 To UBound(arr)
objDic(arr(i, 4)) = ""
Next
With Worksheets("总表")
For Each key1 In objDic.keys
.Range("a1").AutoFilter 4, key1
If Len(Worksheets(key1).Name) = 0 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = key1
End If
.Range("a1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Worksheets(key1).Range("a1")
Next
.Range("a1").AutoFilter
.Activate
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
MsgBox "表格拆分完成", vbInformation
End Sub

复制代码

hwc2ycy · 发表于 2013-5-9 23:49

插入模块，粘贴代码，指定按钮的宏为拆分。

guogongyi · 发表于 2013-8-19 19:04

好用

		自动登录	找回密码
密码			注册