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

zhaogang1960

我用上面的附件测试没有超过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

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

2011-4-13 08:52 上传

点击文件名下载附件

gfs57

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

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

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

gfs57

原帖由 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

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

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

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

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

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

星语心愿

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

天虹染厂/众益包

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

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