Какой самый быстрый способ получить данные из файла Excel?

Question

Моя задача - скопировать диапазон F1: F200 из нескольких тысяч файлов Excel и вставить их в соседние столбцы в папке назначения.Макрос работает, но для открытия каждого файла требуется около 5 секунд.

Я думал о функции запроса «Получить данные», но я не знаком с ней.Я даже не мог определить, можно ли импортировать один диапазон и вставить его туда, где он вам нужен.

Существуют ли другие способы ускорения процесса?

(я видел этот пост: Считайте файл Excel, не открывая его, и скопируйте содержимое в первую пустую ячейку столбца , но я не могу попытаться сделать это еще 12 часов. Я надеюсь, что к тому времени кто-то скажет мне, что он определенно быстрее или определенномедленнее или что-то в этом роде.)

РЕДАКТИРОВАТЬ: Я думал, что сказать «открыть, скопировать и вставить» было достаточным описанием процесса, но лучше всего показать вам:

Sub LoopThroughFiles()
Dim StrFile As String
Dim aBook As Workbook, DestSheet As Worksheet
Dim dest As Range
Dim CurDir As String
Dim diaFolder As FileDialog

Set DestSheet = ThisWorkbook.Sheets("data modified")


' Chose directory 
MsgBox "Select Folder"
' Open the file dialog
Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
'FIX: how to make the current directory the default for diaFolder?
diaFolder.AllowMultiSelect = False
diaFolder.Show

'This captures the Folder pathname
CurDir = diaFolder.SelectedItems(1)

ChDir CurDir
'cleanup
Set diaFolder = Nothing

StrFile = Dir(CurDir & "\*.xls")    
Dim aCell As Range

Do While Len(StrFile) > 0

    ' First cell of destination range
    DestSheet.Range("T4").End(xlToRight).Offset(-3, 1).Select
    'Open a workbook
    Set aBook = Workbooks.Open(Filename:=StrFile, ReadOnly:=True)

    ' Copy from Column F and the Paste
    aBook.Sheets(1).Range("F1", Range("F65536").End(xlUp)).Copy 
    DestSheet.Paste

    ' Close the book
    aBook.Application.CutCopyMode = False
    aBook.Close SaveChanges:=False

    StrFile = Dir
Loop


MsgBox "Done"

Answer 1

Это метод для использования oledb.

Dim Rs As Object

Sub LoopThroughFiles()
    Dim StrFile As String
    Dim aBook As Workbook, DestSheet As Worksheet
    Dim dest As Range
    Dim CurDir As String
    Dim diaFolder As FileDialog
    Dim Fn As String
    Dim Target As Range
    Dim strSQL As String

    Set DestSheet = ThisWorkbook.Sheets("data modified")


    ' Chose directory
    MsgBox "Select Folder"
    ' Open the file dialog
    Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
    'FIX: how to make the current directory the default for diaFolder?
    diaFolder.AllowMultiSelect = False
    diaFolder.Show

    'This captures the Folder pathname
    CurDir = diaFolder.SelectedItems(1)

    ChDir CurDir
    'cleanup
    Set diaFolder = Nothing

    StrFile = Dir(CurDir & "\*.xls")
    Dim aCell As Range

    strSQL = "Select * from [Report$F1:F65536] "

    Do While Len(StrFile) > 0
        Fn = CurDir & "\" & StrFile
        ' First cell of destination range
        Set Target = DestSheet.Range("T4").End(xlToRight).Offset(-3, 1)
        getRs Fn, strSQL
        Target.CopyFromRecordset Rs
        Rs.Close
        Set Rs = Nothing

        StrFile = Dir
    Loop


    MsgBox "Done"
End Sub

Sub getRs(Fn As String, strQuery As String)
    Dim strConn As String

    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & Fn & _
             ";Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"";"

    Set Rs = CreateObject("ADODB.Recordset")
    Rs.Open strQuery, strConn

End Sub

Answer 2

Это должно быть немного быстрее

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim target As Range
Set target = DestSheet.Range("T4").End(xlToRight).Offset(-3, 1)

Do While Len(StrFile) > 0


    'Open a workbook
    Set aBook = Workbooks.Open(Filename:=StrFile, ReadOnly:=True)

    ' Copy from Column F and then Paste
    aBook.Sheets(1).Range("F1:F200").Copy
    target.PasteSpecial xlPasteAll

    ' Close the book
   ' aBook.Application.CutCopyMode = False 'not needed
    aBook.Close SaveChanges:=False
 Set target = target.Offset(0, 1) 'move pointer 1 column right
    StrFile = Dir
Loop