통합 문서간에 값 복사

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 응용 프로그램을 열었습니다. 나는 아직 (를 열지 않고) 폐쇄 엑셀 파일에 쓰기를 시도하지 않은 (그러나 나는 그것이 훨씬 더 빨리 작동 될 수없는 것이라고 생각)

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