Question

我制作了一个在工作簿之间复制值的代码。问题是它太慢了（复制到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个文件），第二行到第二个工作簿等。此行复制到表5x110中，其中数据按列填充（第一行）行的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

Answer 1

真棒！执行时间大大缩短为3分19秒！谢谢@chrisneilsen的建议！

以下是编辑过的代码：

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

在工作簿之间复制值

1 个答案: