Я написал надстройку vba, которая подключается к другому файлу Excel и извлекает данные из них с помощью команды SQL.
При первой же попытке, кажется, все в порядке, когда тратится около 7-6 сек. 200.000 записей. Но теперь он становится все длиннее и длиннее после запусков
Есть ли способ уменьшить затраченное время при извлечении данных?
Команда SQL:
Select [ngày ct],[mã khách],[tên khách],[số ct],[mã ct],[Diễn giải],([Phát sinh nợ]-[Phát sinh có]) as [Amount],[tài khoản],[tk đối ứng],[vụ việc],[tên vụ việc],[bộ phận],[phí] from [Sheet1$] order by [Vụ việc] desc, [ngày ct],[số ct],[tài khoản],[tk đối ứng]
Код VBA:
Sub export_data()
'On Error Resume Next
'Set clr = Application.InputBox("Clearing range", "Select range to clear", Type:=8)
'clr.ClearContents
Application.ScreenUpdating = False
Set c1 = ActiveSheet.Range("B1")
Set c2 = ActiveSheet.Range("B2")
Set c3 = ActiveSheet.Range("A7")
'Range(c3, c3.End(xlToRight)).Select
'Range(Selection, Selection.End(xlDown)).ClearContents
With ActiveSheet
.Range("A6:AA700000").ClearContents
End With
On Error Resume Next
If IsEmpty(c1) Then
Set flg = Application.FileDialog(msoFileDialogFilePicker)
With flg
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add Description:="Database file type", Extensions:="*.xls,*.xlsx"
.Filters.Add Description:="All types", Extensions:="*.*"
.Title = "Chon file database"
If .Show = -1 Then
dtpth = .SelectedItems(1)
'Dim wb As Workbook
'Dim ws As Worksheet
'Set wb = Application.Workbooks.Open(Filename:=dtpth)
'ActiveWorkbook.Application.Visible = True
'Set ws = wb.Worksheets("sheet1")
'ws.Rows("1:5").Delete
'ActiveWorkbook.Close Savechanges:=True
'Set c1 = Application.InputBox(Prompt:="Save address", Title:="Save database address", Type:=8)
c1.Value = dtpth
End If
End With
Else
dtpth = c1.Value
End If
Set conn = New ADODB.Connection
With conn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & dtpth & ";Extended Properties='Excel 12.0 Xml;HDR=YES;IMEX=1';"
.CursorLocation = adUseClient
.Open
'If .State = adStateOpen Then
'MsgBox "Welcome " & Environ("username") & " connected to Data"
'End If
End With
'Set c2 = Application.InputBox(Prompt:="Select command", Title:="Select SQL command", Type:=8)
If IsEmpty(c2) Then
c2.Value = "Select * from [sheet1$]"
comm = c2.Value
Else
comm = c2.Value
End If
starttime = Timer
Set rc = New ADODB.Recordset
'rc.CursorLocation = adUseClient
Set rc = conn.Execute(comm)
With rc
'Set c3 = Application.InputBox(Prompt:="Paste data to", Title:="Data range", Type:=8)
'If IsEmpty(Range("A6:AZ6")) Then
For header = 1 To .Fields.Count
Cells(c3.Row - 1, header).Value = .Fields(header - 1).Name
Next header
'End If
c3.CopyFromRecordset rc
endtime = Timer - starttime
ActiveSheet.Range("B3").Value = endtime
ActiveSheet.Range("B4").Value = .RecordCount
End With
rc.Close
conn.Close
Set rc = Nothing
Set conn = Nothing
Application.ScreenUpdating = True
End Sub