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

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
  

  回复于 2024-04-26T19:00:17+08:00