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

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

1 个答案: