达到按某列拆分为工作薄（加密并保持列宽行高）

乐乐2006201505

各位大师，附件中代码已达到我的要求，但是速度很慢，如果上百人，甚至上千人的话，需要时间有些长，能否优化代码，达到提速的目的，谢谢！
同高同宽.zip (27.02 KB, 下载次数: 34)

2017-1-23 23:03 上传

点击文件名下载附件

microyip

我做了一个代码，理论上比你的速度快，直到SaveAs前都不你快，但实际比你的慢，慢就慢在同样一句的saveas上，我自己也比较莫名其妙搞不清楚

microyip

1. Sub 创建工作薄并按要求命名同高同宽()
   
2.     Dim vTimer As Variant
   
3.     Dim vData As Variant, nRow As Integer, nCol As Integer, rRNG As Range, nCols As Integer
   
4.     Dim vRowHeight As Variant, vColumnWidth As Variant, sPath As String
   
5.    
   
6.     vTimer = Timer
   
7.     Application.ScreenUpdating = False
   
8.     sPath = ThisWorkbook.Path & ""
   
9.     With Sheets("数据")
   
10.         vData = .[A2].CurrentRegion.Value
    
11.         nCols = UBound(vData, 2)
    
12.         ReDim vRowHeight(1 To 3)
    
13.         For nRow = 1 To 3
    
14.             vRowHeight(nRow) = Cells(nRow, 1).RowHeight
    
15.         Next
    
16.         ReDim vColumnWidth(1 To nCols)
    
17.         For nCol = 1 To nCols
    
18.             vColumnWidth(nCol) = Cells(2, nCol).ColumnWidth
    
19.         Next
    
20.         Set rRNG = .[A2].Resize(3, nCols).Offset(-1)
    
21.     End With
    
22.     With Application.Workbooks.Add(xlWBATWorksheet)
    
23.         With .Sheets(1)
    
24.             For nRow = 1 To 3
    
25.                 .Cells(nRow, 1).RowHeight = vRowHeight(nRow)
    
26.             Next
    
27.             For nCol = 1 To nCols
    
28.                 .Cells(2, nCol).ColumnWidth = vColumnWidth(nCol)
    
29.             Next
    
30.             rRNG.Copy .[A1]
    
31.         End With
    
32.         For nRow = 3 To UBound(vData)
    
33.             If vData(nRow, 1) <> "" Then
    
34.                 With .Sheets(1)
    
35.                     .Name = vData(nRow, 1)
    
36.                     .[A3].Resize(, nCols) = Application.Index(vData, nRow, 0)
    
37.                 End With
    
38.                 .SaveAs Filename:=sPath & vData(nRow, 1) & ".xlsx", Password:=Right(vData(nRow, 2), 6)
    
39.             End If
    
40.         Next
    
41.         .Close
    
42.     End With
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox Format(Timer - vTimer, "0.0000s")
    
45. End Sub

复制代码

microyip

假如两个代码都屏蔽SaveAs，以及Close False，时间上看得很清楚，我的才用0.25秒，你的要3秒几。提供附件以供你共同参考

microyip

找到原因了，我更改你的文件名后，没有把你原来激活原工作簿的代码相应位置给改了导致

乐乐2006201505

microyip 发表于 2017-1-24 02:07
找到原因了，我更改你的文件名后，没有把你原来激活原工作簿的代码相应位置给改了导致

Sheets(1).[a1].PasteSpecial Paste:=xlPasteColumnWidths
可否用这种方式保留列宽，提高速度。

您的这个代码可以提速2秒左右，已经很不错了，不知道还有没有更快的方法，将速度提升到半秒每行。最终200多人就是2分钟左右。现在情况是6-8分钟时间，感觉有些慢。谢谢啦！
祝您新春愉快，身体健康，万事如意，阖家幸福！
顺祝长期以来给予我无私帮助的各位老师，广大坛友新春愉快，身体健康，万事如意，阖家幸福！

lsc900707

乐乐2006201505 发表于 2017-1-24 09:15
Sheets(1).[a1].PasteSpecial Paste:=xlPasteColumnWidths
可否用这种方式保留列宽，提高速度。

电脑什么配置呀，6-8分钟？

乐乐2006201505

我电脑本附件中六行内容拆分最快11秒，我想要3秒左右完成，难度挺大的。
如果数据为260行的话，拆分为260个加密工作薄，需要6-8分钟。