在工作簿之间复制值
我做了一个在工作簿之间复制值的代码。 问题是速度太慢（复制到60个文件需要将近30分钟）。 我认为这是因为我为每个细胞设定了价值。
For Each cl In rg For c = 0 To 4 wb.ActiveSheet.Cells(i + c, 2 + n).Value = cl.Offset(r - 2, c).Value Next n = n + 1 Next 我这样做的原因是任务：有60行单元格（每个单元格中有一个公式）（每行550个单元格）。 必须将第一行的值（结果，不是公式）复制到第一个Excel工作簿（有60个文件），第二行到第二个工作簿等。该行复制到表5×110，其中数据由列填充（第一个该行的5个单元格 – 是第一列等）。
如何优化这个？ （我试过复制过去的值 – 变得没有响应）。 我已经在隐形模式下打开Excel应用程序。 我还没有试图写封闭的Excel文件（没有打开它）（但我认为它不会变得更快）
Sub CopyM() Dim rg As Range, r As Long, c As Long, wb As Excel.Workbook, col As Long, i As Long, j(1 To 60) As String, k As Long Dim FileName As String Dim app As New Excel.Application Dim FolderPath As String, p As String, cl As Range, n As Long app.Visible = False i = 2 For k = 1 To 60 If k < 51 Then j(k) = k Else j(k) = ("d" & (k - 50)) End If Next k Set rg = Range("K2") Application.ScreenUpdating = False For col = 16 To 560 Step 5 Set rg = Union(rg, Cells(2, col)) Next col p = ActiveWorkbook.Path FolderPath = (p & "\") FileName = (FolderPath & j(1) & ".xlsm") n = 0 For r = 2 To 61 FileName = (FolderPath & j(r - 1) & ".xlsm") Set wb = app.Workbooks.Open(FileName) n = 0 For Each cl In rg For c = 0 To 4 wb.ActiveSheet.Cells(i + c, 2 + n).Value = cl.Offset(r - 2, c).Value Next n = n + 1 Next wb.Close savechanges:=True app.Quit Application.ScreenUpdating = True Cells(1, 1).Value = (r - 1) & "/60" Application.ScreenUpdating = False Next Set app = Nothing Application.ScreenUpdating = True Cells(1, 1).Value = "" MsgBox "Finished" End Sub
棒极了！！ 执行时间明显减less到3分19秒！ 谢谢@chrisneilsen的build议！
这里是编辑的代码：
Sub CopyM() Dim r As Long, wb As Excel.Workbook, i As Long, p As String, n As Long Dim FileName As String, j(1 To 60) As String, k As Long Dim app As New Excel.Application Dim FolderPath As String, ai As Variant, bi(1 To 5, 1 To 110) As Variant app.Visible = False For k = 1 To 60 If k < 51 Then j(k) = k Else j(k) = ("d" & (k - 50)) End If Next k Application.ScreenUpdating = False p = ActiveWorkbook.Path FolderPath = (p & "\") FileName = (FolderPath & j(1) & ".xlsm") r = 2 i = 0 n = 1 For r = 2 To 61 ai = Range(Cells(r, 11), Cells(r, 560)).Value i = 0 n = 1 For i = 1 To 550 Step 5 bi(1, n) = ai(1, i) bi(2, n) = ai(1, 1 + i) bi(3, n) = ai(1, 2 + i) bi(4, n) = ai(1, 3 + i) bi(5, n) = ai(1, 4 + i) n = n + 1 Next FileName = (FolderPath & j(r - 1) & ".xlsm") Set wb = app.Workbooks.Open(FileName) wb.ActiveSheet.Range("B2:DG6").Value = bi wb.Close savechanges:=True app.Quit Application.ScreenUpdating = True Cells(1, 1).Value = (r - 1) & "/60" Application.ScreenUpdating = False Next Set app = Nothing Application.ScreenUpdating = True Cells(1, 1).Value = "" MsgBox "Finished" End Sub