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

loading...


0

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

loading...

1回答

  • 0

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

    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
    
评论

暂时没有评论!