Excel에서 Excel 테이블로 데이터를 가져 오기위한 Excel vba 속도 최적화

Question

Excel 테이블로 데이터를 가져올 때 vba 스크립트의 속도에 문제가 있습니다. 여기있는 사람을 원하면 도움이 될 수 있습니다. 내 코드 상태의 주석으로이 스크립트는 약 100 초의 데이터 행을 가져 오는 데 약 8 초가 걸립니다. 나는 그것을 몇 분의 1 초로 낮추고 싶다.

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