エクセルテーブルからエクセルテーブルにデータをインポートするエクセルvba速度最適化

Question

エクセルテーブルにデータをインポートするためのvbaスクリプトの速度に問題があります。ここに誰かを援助することができます。私のコード状態のコメントとして、このスクリプトは100行のデータをインポートするのに約8秒かかります。私はそれを数分の一にまで降ろしたいと思っています。

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 

私はUsedRange上CurrentRegionを好みます。

設定importRg = importWb.Worksheets（1）.Range（ "A1"）。CurrentRegion