用于将数据从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