CODEWITHSUNDEEP
vbaexcel
Samuel
Samuel

Reputation: 103

Copy values between workbooks

I've made a code that copy values between workbooks. The problem is it is too slow (it takes almost 30 minutes to copy to 60 files). I think it's because I set value for each cell.

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

The reason I do it is the task: there are 60 rows of cells (there is a formula in each cell) (550 cells in each row). Values (results, not formulas) of first row must be copied to the first excel workbook (there are 60 files), second row to the second workbook, etc. This row is copied in the table 5x110 where data is filled by columns (first 5 cells of the row - is the first column, etc.).

How to optimize this? (I've tried copy - past values - becomes not responding). I've already done opening Excel Application in invisible mode. I haven't tried to write to the closed excel file (without opening it) yet (but I think it will not become working much faster)

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

Upvotes: 0

Views: 1069

Answers (1)

Samuel
Samuel

Reputation: 103

That's awesome!! The time of execution significantly reduced to 3 minutes 19 seconds! Thank you @chrisneilsen for suggestion!

Here is the edited code:

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

Upvotes: 1

Related Questions