请vba高手帮忙做一个拆分工作表另存为工作簿的宏

mjzxlmg · 发表于 2011-4-12 20:58

请vba高手帮忙做一个拆分工作表另存为工作簿的宏
有一成绩总表，想根据班号拆分工作表，具体要求见附件。不胜感谢！

zhaogang1960 · 发表于 2011-4-12 22:26

Sub Macro1()
Dim arr, brr, sh As Worksheet, MyPath$, i&, lr&, m&, s$, a As Shape
Set sh = ActiveSheet
lr = Range("A65535").End(xlUp).Row
With Range("A5:AA" & lr)
      .Sort Key1:=[b5].Resize(lr - 4), Order1:=xlAscending
      arr = .Value
End With
ReDim brr(1 To UBound(arr), 1)
For i = 1 To lr - 4
      If arr(i, 2) <> s Then
         m = m + 1
         brr(m, 0) = arr(i, 2)
         brr(m, 1) = i + 4
         s = arr(i, 2)
      End If
Next
brr(m + 1, 1) = i + 4
MyPath = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 1 To m
      sh.Copy
      With ActiveSheet
         .UsedRange.Offset(4).Clear
         sh.Cells(brr(i, 1), 1).Resize(brr(i + 1, 1) - brr(i, 1), 27).Copy .[a5]
         For Each a In .Shapes
            a.Delete
         Next
      End With
      ActiveWorkbook.SaveAs MyPath & brr(i, 0) & ".xls"
      ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
MsgBox "ok"
End Sub

zhaogang1960 · 发表于 2011-4-12 22:27

拆分为工作簿.rar (56.99 KB, 下载次数: 212)

mjzxlmg · 发表于 2011-4-12 22:33

侠圣出手了。zhaogang1960真是太好人呀，这么快就搞好了。我测试一下。
谢谢了。

经测试很好用。
但是速度有点慢，能有改善的办法吗？
还有就是：Application.DisplayAlerts = False
最后没有改回：Application.DisplayAlerts = True
有影响到工作表的工作吗？
看了一个帖子说，在 Copy 语句后用Application.CutCopyMode = False清除剪贴板内容有助于改善运行速度，不知是否有效呢？

[ 本帖最后由 mjzxlmg 于 2011-4-12 23:06 编辑 ]

mjzxlmg · 发表于 2011-4-12 22:14

自己顶上去，别沉了。

zhaogang1960 · 发表于 2011-4-12 23:07

原帖由 mjzxlmg 于 2011-4-12 22:33 发表
侠圣出手了。zhaogang1960真是太好人呀，这么快就搞好了。我测试一下。
谢谢了。

经测试很好用。
但是速度有点慢，能有改善的办法吗？
还有就是：Application.DisplayAlerts = False
最后没有改回：Applicati ...

原来都是用字典或sql拆分，这次用排序，看来效果不佳，马上修改

zhaogang1960 · 发表于 2011-4-12 23:18

字典法：
Sub Macro1()
Dim arr, sh As Worksheet, MyPath$, k, t, i&, dc&, s$, a As Shape
Set sh = ActiveSheet
arr = Range("b1:b" & Range("b65535").End(xlUp).Row)
MyPath = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With CreateObject("scripting.dictionary")
      For i = 5 To UBound(arr)
         s = arr(i, 1)
         If Not .Exists(s) Then
            .Add s, sh.Cells(i, 1).Resize(1, 27)
         Else
            Set .Item(s) = Union(.Item(s), sh.Cells(i, 1).Resize(1, 27))
         End If
      Next
      k = .keys
      t = .Items
      dc = .Count
End With
For i = 0 To dc - 1
      sh.Copy
      With ActiveSheet
         .[a1].CurrentRegion.Offset(4).ClearContents
         t(i).Copy .[a5]
         For Each a In .Shapes
            a.Delete
         Next
      End With
      ActiveWorkbook.SaveAs MyPath & k(i) & ".xls"
      ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
MsgBox "ok"
End Sub

zhaogang1960 · 发表于 2011-4-12 23:20

拆分为工作簿.rar (57.08 KB, 下载次数: 143)

如果还感觉慢，可以考虑使用上面排序+数组

gfs57 · 发表于 2011-4-12 23:25

原帖由 zhaogang1960 于 2011-4-12 22:26 发表
Sub Macro1()
Dim arr, brr, sh As Worksheet, MyPath$, i&, lr&, m&, s$, a As Shape
Set sh = ActiveSheet
lr = Range("A65535").End(xlUp).Row
With Range("A5:AA" & lr)
.Sort Key ...

谢谢你，学习了 ! 留个记号，明天再研究。

mjzxlmg · 发表于 2011-4-12 23:44

原帖由 zhaogang1960 于 2011-4-12 23:20 发表
905471

如果还感觉慢，可以考虑使用上面排序+数组

两种方法均试了，删除一些数据，只保留四个班，然后进行了用时测试，我的测试用字典法要快。
两种方法同样的数据用时比较：
字典法：9.97秒；
排序+数组：13.25秒

18个班用时测试结果：用排序+数组要快。
字典法：54.30秒；
排序+数组：42.30秒

[ 本帖最后由 mjzxlmg 于 2011-4-13 00:30 编辑 ]

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

[求助] 请vba高手帮忙做一个拆分工作表另存为工作簿的宏