[已解决]提速 按某列拆分为工作薄（加密并保持列宽行高）

乐乐2006201506

代码已实现要求，现在测试要用11-13秒，能否优化或重写代码（因为我实际数据有260行左右，按6行数据11秒算，实际数据就得7-9分钟完成，时间有些长），最好能在3-5秒完成，或者9秒内完成。谢谢！

最佳答案

月排行榜 / 总排行榜

zjdh

2017-1-25 18:02

噢，我忘了设置路径啦。
Sub 创建工作薄并按要求命名同高同宽2()
     Dim vTimer As Variant
     Dim vData As Variant, nCols As Integer, I As Integer, sPath As String
     Application.ScreenUpdating = False
     vTimer = Timer
     Sheets("数据").Copy
     With ActiveSheet
         vData = .[A2].CurrentRegion.Value
         nCols = UBound(vData, 2)
         .Rows("4:500").Delete
         For I = 3 To UBound(vData)
             If vData(I, 1) <> "" Then
                 .Name = vData(I, 1)
                 .[A3].Resize(, nCols) = Application.Index(vData, I, 0)
                 ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & vData(I, 1) & ".xlsx", Password:=Right(vData(I, 2), 6)
             End If
         Next
         ActiveWorkbook.Close
     End With
     Application.ScreenUpdating = True
     MsgBox Format(Timer - vTimer, "0.0000s")
End Sub

运行时间由于存储需要时间，是无法缩短的！

跳转到最佳答案楼层

zjdh

你的文件生成宏运行时间长，不在于宏的繁杂，而在于文件保存时间占用，无法缩短啦。
不过语句到可以简化一下：
Sub 创建工作薄并按要求命名同高同宽2()
    Dim vTimer As Variant
    Dim vData As Variant, nCols As Integer, I As Integer, sPath As String
    Application.ScreenUpdating = False
    vTimer = Timer
    Sheets("数据").Copy
    With ActiveSheet
        vData = .[A2].CurrentRegion.Value
        nCols = UBound(vData, 2)
        .Rows("4:500").Delete
        For I = 3 To UBound(vData)
            If vData(I, 1) <> "" Then
                .Name = vData(I, 1)
                .[A3].Resize(, nCols) = Application.Index(vData, I, 0)
                ActiveWorkbook.SaveAs Filename:=sPath & vData(I, 1) & ".xlsx", Password:=Right(vData(I, 2), 6)
            End If
        Next
        ActiveWorkbook.Close
    End With
    Application.ScreenUpdating = True
    MsgBox Format(Timer - vTimer, "0.0000s")
End Sub

乐乐2006201506

zjdh 发表于 2017-1-25 13:48
你的文件生成宏运行时间长，不在于宏的繁杂，而在于文件保存时间占用，无法缩短啦。
不过语句到可以简化一 ...

万分感谢！祝您新春愉快，万事顺意！

乐乐2006201506

zjdh 发表于 2017-1-25 13:48
你的文件生成宏运行时间长，不在于宏的繁杂，而在于文件保存时间占用，无法缩短啦。
不过语句到可以简化一 ...

zjdh老师，代码运行后，出现了以下问题：
1.保存文件位置（保存到我的文档了）出问题了；2.时间（400多秒）并未缩短。

zjdh

噢，我忘了设置路径啦。
Sub 创建工作薄并按要求命名同高同宽2()
     Dim vTimer As Variant
     Dim vData As Variant, nCols As Integer, I As Integer, sPath As String
     Application.ScreenUpdating = False
     vTimer = Timer
     Sheets("数据").Copy
     With ActiveSheet
         vData = .[A2].CurrentRegion.Value
         nCols = UBound(vData, 2)
         .Rows("4:500").Delete
         For I = 3 To UBound(vData)
             If vData(I, 1) <> "" Then
                 .Name = vData(I, 1)
                 .[A3].Resize(, nCols) = Application.Index(vData, I, 0)
                 ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & vData(I, 1) & ".xlsx", Password:=Right(vData(I, 2), 6)
             End If
         Next
         ActiveWorkbook.Close
     End With
     Application.ScreenUpdating = True
     MsgBox Format(Timer - vTimer, "0.0000s")
End Sub

运行时间由于存储需要时间，是无法缩短的！

乐乐2006201506

zjdh 发表于 2017-1-25 18:02
噢，我忘了设置路径啦。
Sub 创建工作薄并按要求命名同高同宽2()
     Dim vTimer As Variant

您这个是怎么保持原工作表行高和列宽的？ 另外，您的代码也没有提高速度啊！麻烦您再看看。谢谢！

zjdh

1.你看一下代码不就明白啦，是直接复制----删除多余。
2.我不是说啦“由于存储需要时间，运行时间是无法再缩短了！”

乐乐2006201506

zjdh 发表于 2017-1-26 23:00
1.你看一下代码不就明白啦，是直接复制----删除多余。
2.我不是说啦“由于存储需要时间，运行时间是无法再 ...

嗯，最后看明白了。如果不加密，速度会快些。谢谢！