问如何在Excel VBA中加速数据文件导入

EN

Private Sub Btn_ImportDataFiles_Click()
  ' Search the current worksheet and assign the next TransactionID
    Dim TransactionCounter As Integer
    Dim TransactionID As Long ' This is the next available Transaction ID
    TransactionID = Application.WorksheetFunction.Max(Range("a:a")) + 1
  ' open the file and import the data
    Dim customerBook As Workbook
    Dim filter As String
    Dim caption As String
    Dim customerFilename As String
    Dim customerWorkbook As Workbook
    Dim targetWorkbook As Workbook

    ' make weak assumption that active workbook is the target
      Set targetWorkbook = Application.ActiveWorkbook

    ' get the customer workbook
      filter = "Text files (*.xlsx),*.xlsx"
      caption = "Please Select an input file "
      customerFilename = Application.GetOpenFilename(filter, , caption)

    If customerFilename <> "False" Then
    ' If they have uploaded the file before, let them know.
    ' If they want to keep uploading it, no harm done,
    ' but no need to stupidly add data that is already present.
    ' Select the archive sheet
      Sheets("Upload_Archive").Select
      Dim FileNameHunt As String
      Dim cell As Range
      Dim ContinueUpload As Boolean
      ContinueUpload = True
      FileNameHunt = Mid(customerFilename, InStrRev(customerFilename, "\") + 1)
      Columns("A:A").Select
      Set cell = Selection.Find(what:=FileNameHunt, after:=ActiveCell, LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=False, searchformat:=False)
      If cell Is Nothing Then ' Add the new filename to the archive
        Sheets("Upload_Archive").Select
        Rows(1).Insert shift:=xlDown
        Range("a1:a1").Value = FileNameHunt
        Sheets("MasterSheet").Select
        Application.Cells.Font.Name = "Calibri Light"
        Application.Cells.Font.Size = "8"
        Application.Cells.Font.Bold = False
      Else
        response = MsgBox("This data file has previously been uploaded. " & vbCrLf & "Do you want to cancel this upload?" & vbCrLf & vbCrLf & "Pressing [yes] will cancel the process." & vbCrLf & "Pressing [no] will continue with the file upload" & vbCrLf & "and add the data to the tracking sheet.", vbYesNo)
        If response = vbYes Then
          ContinueUpload = False
          Sheets("MasterSheet").Select
          Exit Sub
        End If
      End If ' If cell Is Nothing Then...

      If ContinueUpload = True Then
        ' Continue with data upload procedure
          Sheets("MasterSheet").Select
          Set customerWorkbook = Application.Workbooks.Open(customerFilename)
        ' Copy data from customer to target workbook
          Dim targetSheet As Worksheet
          Set targetSheet = targetWorkbook.Worksheets(1)
          Dim sourceSheet As Worksheet
          Set sourceSheet = customerWorkbook.Worksheets(1)
          Dim ImportRecordCount As Integer
          ImportRecordCount = sourceSheet.Range("B1")
          Dim ReconciliationID As String
          ReconciliationID = ""
          If sourceSheet.Range("E3") = "Removed from Depot" Then ReconciliationID = "1"
MsgBox ("Step 1")
          targetSheet.Range("A1").EntireRow.Offset(1).Resize(ImportRecordCount).Insert shift:=xlDown ' Add the blank rows
MsgBox ("Step 2")
          targetSheet.Range("B2:AB" & ImportRecordCount + 1).Value = sourceSheet.Range("A3:AA" & ImportRecordCount + 2).Value ' Bring in the big pile of data
MsgBox ("Step 3")
          targetSheet.Range("AJ2:AJ" & ImportRecordCount + 1).Value = ReconciliationID ' To help with reconciling shipments
          targetSheet.Range("AK2:AK" & ImportRecordCount + 1).Value = ReconciliationID ' To help with deployment timing
          'targetSheet.Range("AI2:AI" & ImportRecordCount + 1).Value = "=COUNTIFS($D:$D, D2, $F:$F, F2)" ' This is the helper formula for identifying duplicates (deprecated, but I'm saving the code)
          For TransactionCounter = 2 To ImportRecordCount + 1 ' Create and add the new Transaction ID values
            targetSheet.Range("a" & TransactionCounter) = TransactionID + ImportRecordCount - TransactionCounter + 1
          Next
        ' Close customer workbook
          customerWorkbook.Close
        ' Format the sheet properly
          Application.Cells.Font.Name = "Calibri Light"
          Application.Cells.Font.Size = "8"
          Application.Cells.Font.Bold = False
          Application.Range("1:1").Font.Size = "10"
          Application.Range("1:1").Font.Bold = True
        ' Query the User -- delete the file?
          If MsgBox("Delete the local client-generated data file?" & vbCrLf & vbCrLf & "(this will NOT affect your email)", vbYesNo, "Confirm") = vbYes Then
            Kill customerFilename
            ' MsgBox ("File: " & vbCrLf & customerFilename & vbCrLf & "has been deleted.")
          End If
      End If ' If ContinueUpload = True Then
    End If ' If customerFilename <> "False" Then

End Sub

    MsgBox ("Step 2")

        'Ive never moved large amounts of data using this method. Ive always just used arrays. I have moved smaller bits of data though.
        ' I suspect that this might take a moment if the data set is large. Again use arrays to grab the data and move it.
        ' Edward says “This step takes about 70% of my delay — even if bringing in only a single line of data.”

        targetSheet.Range("B2:AB" & ImportRecordCount + 1).Value = sourceSheet.Range("A3:AA" & ImportRecordCount + 2).Value ' Bring in the big pile of data

    MsgBox ("Step 3")

      ' this loop is probably your main culprit of your performance issue. 
      ' Edward says “Nope, this flies by. It is not the issue at all. I have verified this already.”
      ' Learn how to construct an array of data on the fly and then learn how to dump the entire array to 
      ' sheet using a simple method.

        For TransactionCounter = 2 To ImportRecordCount + 1 ' Create and add the new Transaction ID values
            targetSheet.Range("a" & TransactionCounter) = TransactionID + ImportRecordCount - TransactionCounter + 1
        Next