将多个工作簿中的数据复制到主工作簿/崩溃性能问题中

这是我用来将数据从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

回答(1)

2 years ago

让你开始的东西:它没有你想做的一切,但它应该比你的更快,似乎你一行一行地复制 . 它一次完成所有行 . 请记住,这是未经测试的 .

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