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

zhaogang1960 · 发表于 2011-4-13 08:50

我用上面的附件测试没有超过10s的
下面三个方法都是排序法，你可以测一下速度：
Sub Macro1() '排序复制工作表法
tt = Timer
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 Timer - tt
End Sub
Sub Macro2() '排序新建工作簿数组法
tt = Timer
Dim arr, brr, sh As Worksheet, MyPath$, i&, lr&, m&, s$, rng As Range
Set rng = Range("A1:AA4")
      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
      With Workbooks.Add(xlWBATWorksheet)
         With .Sheets(1)
            rng.Copy .[a1]
            arr = sh.Cells(brr(i, 1), 1).Resize(brr(i + 1, 1) - brr(i, 1), 27)
            .[a5].Resize(UBound(arr), 27) = arr
         End With
         .SaveAs Filename:=MyPath & brr(i, 0) & ".xls"
         .Close
      End With
Next
Application.ScreenUpdating = True
MsgBox Timer - tt
End Sub

Sub Macro3() '排序新建工作簿复制区域法
tt = Timer
Dim arr, brr, sh As Worksheet, MyPath$, i&, lr&, m&, s$, rng As Range
Set rng = Range("A1:AA4")
      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
      With Workbooks.Add(xlWBATWorksheet)
         With .Sheets(1)
            rng.Copy .[a1]
            sh.Cells(brr(i, 1), 1).Resize(brr(i + 1, 1) - brr(i, 1), 27).Copy .[a5]
         End With
         .SaveAs Filename:=MyPath & brr(i, 0) & ".xls"
         .Close
      End With
Next
Application.ScreenUpdating = True
MsgBox Timer - tt
End Sub

zhaogang1960 · 发表于 2011-4-13 08:52

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

gfs57 · 发表于 2011-4-13 09:53

原帖由 mjzxlmg 于 2011-4-12 23:44 发表

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

运行速度不单跟代码有关，还与其它诸多因素相关，比如电脑配置等，甚至跟 VBE 窗口是否打开着也有关。
总表里头 18 个班级的数据全部保留，我这边的代码运行速度都是 10 秒多，但不到11 秒。

gfs57 · 发表于 2011-4-13 11:27

原帖由 zhaogang1960 于 2011-4-13 08:50 发表
我用上面的附件测试没有超过10s的
下面三个方法都是排序法，你可以测一下速度：
Sub Macro1() '排序复制工作表法
tt = Timer
Dim arr, brr, sh As Worksheet, MyPath$, i&, lr&, m&, s$, a As Shape
Se ...

方法多多，佩服 !
我有个想法：如果考虑用“高级筛选”然后复制到新簿，速度是否会再提高，新簿也许也能减肥？不知可行否？

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

原帖由 gfs57 于 2011-4-13 09:53 发表

运行速度不单跟代码有关，还与其它诸多因素相关，比如电脑配置等，甚至跟 VBE 窗口是否打开着也有关。
总表里头 18 个班级的数据全部保留，我这边的代码运行速度都是 10 秒多，但不到11 秒。

上面12楼的文件，总表里头 18 个班级的数据全部保留，我的电脑测试速度如下：
排序复制工作表法:12.12秒
排序新建工作簿数组法： 6.35秒
排序新建工作簿复制区域法： 5.81秒

加上前面的测试，用排序新建工作簿数组法、排序新建工作簿复制区域法较快些，其它三种略慢些。

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

星语心愿 · 发表于 2011-12-18 18:34

请教一下三楼的zhaogang1960 朋友，如果反过来要把这十八个工作薄的内容汇总到总表里面如何写个代码呢？
意思就是和楼主的要求相反，有空帮忙写个宏吗？有点急用。

天虹染厂/众益包 · 发表于 2021-4-8 03:10

zhaogang1960 发表于 2011-4-12 23:18
字典法：
Sub Macro1()
Dim arr, sh As Worksheet, MyPath$, k, t, i&, dc&, s$, a As Shape

你好。原代码是复制标题行的全部内容。如果只需要复制部份的列，比如20列的内容，我只需要复制15列的内容。请问怎样修改？麻烦一下，谢谢了

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

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