Copy data from multiple workbooks into master workbook / Crash-Performance problem

Question

Here is the macro that I am using as copying data from 6 workbooks into master workbook. Problem is it takes so long to copy all the data and resulting in a momentary screen flash.

I have exact same 5 more loops to get data from 5 other workbooks.

Code works so slowly and causing crashes all the time. Is there a way to simply the code below?

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

You may find something useful in this : https://stackoverflow.com/a/30605765/4961700 — Solar Mike, Dec 10 '18 at 11:10
Windows("").activate parts root cause of the problem but I couldnt find a solution. — mesakon, Dec 10 '18 at 12:05

score 0 · Answer 1 · answered Dec 10 '18 at 12:32

Something to get you started: it doesn't do everything you want but it should be quicker than yours, which it seems that you go row by row to copy. It does all the rows in one go. Bear in mind, it's untested.

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

Copy data from multiple workbooks into master workbook / Crash-Performance problem

1 Answers1