时间戳

首页 > 解决方案 > 将数据从多个工作簿复制到主工作簿/崩溃性能问题

excel - 将数据从多个工作簿复制到主工作簿/崩溃性能问题

问题描述

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

标签： excelvba

解决方案

让你开始的东西：它不会做你想做的一切，但它应该比你的更快，看起来你逐行复制。它一口气完成所有行。请记住，它未经测试。

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

推荐阅读