用於將數據從excel導入excel表的Excel vba速度優化

Question

用於將數據導入到Excel表中的vba腳本的速度有問題。希望這裏有人能幫忙。作爲我的代碼狀態中的註釋，此腳本大約需要8秒才能導入100行數據。我很樂意把它降到幾分之一秒。

Sub ImportMyData() 
    Dim filter, caption, importFileName As String 
    Dim importWb As Workbook 
    Dim targetSh, validationSh As Worksheet 
    Dim targetTb As ListObject 
    Dim importRg, targetRg, validationRg As Range 
    Dim i, j, k, targetStartRow As Integer 

    ' Set speed related application settings (this will be restored on exit) 
    With Application 
     .ScreenUpdating = False 
     .Calculation = xlCalculationManual 
     .DisplayStatusBar = False 
     .EnableEvents = False 
    End With 

    ' Set definitions 
    Set targetSh = ThisWorkbook.Sheets("myTargetSheet") 
    Set targetTb = targetSh.ListObjects("myTargetTable") 
    Set targetRg = targetTb.DataBodyRange 
    Set validationSh = ThisWorkbook.Sheets("myValidationSheet") 
    Set validationRg = validationSh.Range("myValidationRange") 

    ' Set filter for the file choose dialog 
    filter = "Text files (*.xlsx),*.xlsx" 

    ' Set UI text for file choose dialog 
    caption = "Chose xlsx file to import " 

    ' Set filename from UI dialog 
    importFileName = Application.GetOpenFilename(Filter, , Caption) 


    ' Show Form to get user input for extra field (will return variable 'myChoice') 
    ImportFormPicker.Show 

    ' Open the import file workbook 
    Set importWb = Application.Workbooks.Open(importFileName) 
    importWb.Windows(1).Visible = False 
    targetSh.Activate 

    ' Set definitions 
    Set importRg = importWb.Worksheets(1).UsedRange 

    ' Unprotects target sheet 
    targetSh.Unprotect 

    ' Get starting row of imported target range for future reference 
    targetStartRow = targetTb.ListRows.Count + 1 

    ' Iterate all rows in import range 
    For i = 1 To importRg.Rows.Count 
     ' Only import row if first cell in row is a date 
     If IsDate(importRg.Cells(i, 1).Value) Then 
      ' Count imported rows 
      k = k + 1 
      ' Insert row at end of target table 
      targetTb.ListRows.Add AlwaysInsert:=True 
      ' Iterate all columns in import range 
      For j = 1 To importRg.Columns.Count 
       With targetRg.Cells(targetTb.ListRows.Count, j) 
        ' Import value 
        .Value = importRg.Cells(i, j).Value 
        ' Set format according to validation range 
        .NumberFormat = validationRg.Cells(2, j).NumberFormat 
       End With 
      Next j 
      With targetRg.Cells(targetTb.ListRows.Count, j) 
       ' Add custom value which was determined by user form 
       .Value = Butik 
       ' Set Format according to validation range 
       .NumberFormat = validationRg.Cells(2, j).NumberFormat 
      End With 
      ' --- Speed troubleshooting = 100 rows imported/~8seconds. 
      If i Mod 100 = 0 Then 
       ThisWorkbook.Activate 
      End If 
      ' --- End Speed troubleshooting 
     End If 
    Next i 

    ' Close the import file workbook without saving 
    importWb.Close savechanges:=False 

    ' Protect target sheet 
    With targetSh 
     ' Protect the target sheet 
     .Protect DrawingObjects:=True, Contents:=True, Scenarios:=True 
     ' Show the target sheet 
     .Visible = True 
     ' Activate the target sheet 
     .Activate 
    End With 

    ' Select imported range 
    targetRg.Range(Cells(targetStartRow, 1), Cells(targetTb.ListRows.Count, j)).Select 

    ' Show user how many rows were imported 
    MsgBox ("Imported " & k & " rows.") 

    ' Restore speed related settings 
    With Application 
     .ScreenUpdating = True 
     .Calculation = xlCalculationAutomatic 
     .DisplayStatusBar = True 
     .EnableEvents = True 
    End With 
End Sub 

Answer 1

這樣的事情，對變量名對不起，做到了快速，同時在通話中，你需要調整

Sub test() 

Dim q As QueryTable 
Dim r As New ADODB.Recordset 
Dim c As New ADODB.Connection 
Dim s As String 

s = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\test\test_conn.xlsx;" & _ 
      "Extended Properties='Excel 12.0 Xml;HDR=YES';" 
c.ConnectionString = s 
c.Open 

r.Open "Select * from [Sheet1$];", c, 1 

With ActiveSheet.QueryTables.Add(_ 
     Connection:=r, _ 
     Destination:=Range("Z1")) 
    .Name = "Contact List" 
    .FieldNames = True 
    .RowNumbers = False 
    .FillAdjacentFormulas = False 
    .PreserveFormatting = True 
    .RefreshOnFileOpen = False 
    .BackgroundQuery = True 
    .RefreshStyle = xlInsertDeleteCells 
    .SavePassword = True 
    .SaveData = True 
    .AdjustColumnWidth = True 
    .RefreshPeriod = 0 
    .PreserveColumnInfo = True 
    .Refresh BackgroundQuery:=False 

End With 


End Sub 

Answer 2

這將做到這一點。

AppendRangeToTable targetTb，importRg

Sub AppendRangeToTable(TargetTable As ListObject, SourceRange As Range) 
    Dim ar 
    Dim r As Range 
    ar = SourceRange.Value 
    Set r = TargetTable.ListRows.Add(AlwaysInsert:=True).Range 
    r.Resize(UBound(ar, 1), UBound(ar, 2)) = ar 
End Sub 

我喜歡CurrentRegion了UsedRange。

設置importRg = importWb.Worksheets（1）.Range（ 「A1」）。CurrentRegion