Копирование данных из нескольких рабочих книг в основную рабочую книгу / проблема с быстродействием

Question

Вот макрос, который я использую для копирования данных из 6 рабочих книг в основную рабочую книгу.Проблема в том, что копирование всех данных занимает так много времени, что приводит к мгновенному миганию экрана.

У меня точно такие же 5 циклов, чтобы получить данные из 5 других книг.

Код работает так медленнои вызывая сбои все время.Есть ли способ просто код ниже?

Do While Cells(j, 2) <> 
Rows(j).Select
Selection.Copy
Windows("Master Register.xls").Activate
Sheets("Sub register").Select
Rows(i).Select
ActiveSheet.Paste

Windows("Tech register.xls").Activate
Sheets("Tech register").Select
Range("B" & j).Select
Selection.Copy

Windows("Master Register.xls").Activate
Sheets("Sub Register").Select
Range("B" & i).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

j = j + 1
i = i + 1

Windows("Tech Register.xls").Activate
Sheets("Tech Register").Select
Loop

Answer 1

Что-то, с чего можно начать: оно не делает все, что вы хотите, но должно быть быстрее, чем у вас, что, кажется, вы копируете построчно.Это делает все ряды за один раз.Имейте в виду, это не проверено.

Private Sub sCopySheets()

  Dim i As Long
  Dim destinationWs As Worksheet

  Set destinationWs = Sheets("ReplaceSheetName")

  i = 1 'that is the row that the first piece of data will go to.
  i = i + fImportSheetFromExcelFile("ReplaceFilePath1", "ReplaceSheetName1", destinationWs, i)
  i = i + fImportSheetFromExcelFile("ReplaceFilePath2", "ReplaceSheetName2", destinationWs, i)
  i = i + fImportSheetFromExcelFile("ReplaceFilePath3", "ReplaceSheetName3", destinationWs, i)
  i = i + fImportSheetFromExcelFile("ReplaceFilePath4", "ReplaceSheetName4", destinationWs, i)
  i = i + fImportSheetFromExcelFile("ReplaceFilePath5", "ReplaceSheetName5", destinationWs, i)

End Sub


Private Function fImportSheetFromExcelFile(ByVal filePath As String, ByVal sheetName As String, ByRef destinationWorksheet As Worksheet, destinationRow As Long) As Long

  Dim cw As Workbook 'current workbook
  Dim nw As Workbook 'workbook that opens
  Dim rangeToCopy As Range
  Dim rowsCopied As Long

On Error GoTo error_catch

  Application.DisplayAlerts = False
  Application.Calculation = xlCalculationManual
  fImportSheetFromExcelFile = 0

  Set cw = ActiveWorkbook
  Set nw = Workbooks.Open(Filename:=filePath, ReadOnly:=True)

  ' Assuming the data you want to copy start in the second row and there aren't any blank cells in column A
  Set rangeToCopy = nw.Worksheets(sheetName).Range(Range("A2"), Range("A2").End(xlDown)).Copy
  Set rangeToCopy = rangeToCopy.EntireRow
  rowsCopied = rangeToCopy.Rows.Count

  destinationWorksheet.Range(Cells(destinationRow, 1)).PasteSpecial xlPasteValues

  nw.Close SaveChanges:=False

  Application.CutCopyMode = False
  cw.Activate
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic
  fImportSheetFromExcelFile = rowsCopied
  Exit Function

error_catch:
  MsgBox "Error in fImportSheetFromExcelFile" & Err.Description
  Err.Clear
  Application.DisplayAlerts = True
  Application.Calculation = xlCalculationAutomatic
  cw.Activate

End Function