Копирование значений между книгами

Question

Я создал код, копирующий значения между книгами. Проблема в том, что она слишком медленная (требуется около 30 минут для копирования в 60 файлов). Я думаю, это потому, что я установил значение для каждой ячейки.

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 в невидимом режиме. Я не пытался написать в закрытой Ехчел (не открывая его) еще (но я думаю, что это не будет работать гораздо быстрее)

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