How do I retrieve data from an Excel Workbook without opening in VBA?

Question

I have a folder, which is selectable by a user, which will contain 128 files. In my code, I open each document and copy the relevant data to my main workbook. All this is controlled through a userform. My problem is the time it takes to complete this process (about 50 seconds) - surely I can do it without opening the document at all?

This code is used to select the directory to search in:

Private Sub CBSearch_Click()
Dim Count1 As Integer

    ChDir "Directory"
    ChDrive "C"
    Count1 = 1

    inputname = Application.GetOpenFilename("data files (*.P_1),*.P_1")

    TBFolderPath.Text = CurDir()

End Sub

This Retrieves the files:

Private Sub CBRetrieve_Click()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim i As Integer
Dim StrLen As Integer
Dim Folder As String
Dim A As String
Dim ColRef As Integer

Open_Data.Hide

StrLen = Len(TBFolderPath) + 1
Folder = Mid(TBFolderPath, StrLen - 10, 10)

For i = 1 To 128
A = Right("000" & i, 3)
    If Dir(TBFolderPath + "\" + Folder + "-" + A + ".P_1") <> "" Then
        Workbooks.OpenText Filename:= _
            TBFolderPath + "\" + Folder + "-" + A + ".P_1" _
            , Origin:=xlMSDOS, StartRow:=31, DataType:=xlDelimited, TextQualifier:= _
            xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
            Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
            Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), TrailingMinusNumbers:=True

        Columns("B:B").Delete Shift:=xlToLeft
        Rows("2:2").Delete Shift:=xlUp

        Range(Range("A1:B1"), Range("A1:B1").End(xlDown)).Copy

        Windows("Document.xls").Activate

        ColRef = (2 * i) - 1

        Cells(15, ColRef).Select
        ActiveSheet.Paste

        Windows(Folder + "-" + A + ".P_1").Activate
        ActiveWindow.Close
    End If
Next i

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

TBFolderPath is the contents of a textbox in the userform, and is the location of the files.

Sorry my code is so messy!

EDIT: An example of the data is:

TA2000 PLOT DATA FILE
FileName: c:\file
Version: 3.01

PlotNumber: 1
TotalPoints: 982
FrIndex: 460
F1Index: 427
F2Index: 498
FaIndex: 513

Transducer Type: 8024-004-A9
Serial Number: 
Date: 09-Aug-2013
Operator: LSP
20-80kHz 
     Time: 10:51:35             
Clf pF:             

Range mS: 0.5               
Aut/Man: Auto               
Shunt pF:               
Shunt uH:               
Step size: 150 Hz               
Rate: Max               
Start: 1.0              
Stop: 150.0             



A---------B-------------C--------------D--------E

0---------0.003695---1.000078---0.2-----12  
0---------0.004018---1.150238---0.2-----12
.
.
.

Where I am interested in A and C. Data has about 1000 entries.

Answer 1

I use something similar to this to cycle through Excel files in a folder and use ADODB to read the contents.

Option Explicit

Private Sub ReadXL_ADODB()
Dim cnn1 As New ADODB.Connection
Dim rst1 As New ADODB.Recordset
Dim arrData() As Variant
Dim arrFields() As Variant
Dim EndofPath As String
Dim fs, f, f1, fc, s, filePath
Dim field As Long
Dim lngCount As Long
Dim filescount As Long
Dim wSheet As Worksheet
Dim lstRow As Long

    Set wSheet = Sheet1 'Set sheet to import data to

    With Application.FileDialog(msoFileDialogOpen)
            .AllowMultiSelect = True
            .Show

        For lngCount = 1 To .SelectedItems.Count
            EndofPath = InStrRev(.SelectedItems(lngCount), "\")
            filePath = Left(.SelectedItems(lngCount), EndofPath)
        Next lngCount

    End With

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(filePath)
    Set fc = f.Files
    filescount = 0

    For Each f1 In fc
        DoEvents
        'Open the connection to Excel then open the recordset
        cnn1.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & CStr(f1) & ";" & _
        "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
        'Imports from sheet named xDatabase and range A:EF
        rst1.Open "SELECT * FROM [xDatabase$A:EF];", cnn1, adOpenStatic, adLockReadOnly

        'If target fields are empty write field names
        If WorksheetFunction.CountA(wSheet.Range("1:1")) = 0 Then
            For field = 0 To rst1.Fields.Count - 1
                wSheet.Range("A1").Offset(0, field).Value = rst1.Fields(field).Name
            Next field
        End If
        arrData = rst1.GetRows

        rst1.Close
        cnn1.Close
        Set rst1 = Nothing
        Set cnn1 = Nothing

        'Transpose array for writing to Excel
        arrData = TransposeDim(arrData)

        lstRow = LastRow(wSheet.Range("A:EF"))
        wSheet.Range("A1").Offset(lstRow, 0).Resize(UBound(arrData, 1) + 1, UBound(arrData, 2) + 1).Value = arrData
        filescount = filescount + 1
        Application.StatusBar = "Imported file " & filescount & " of " & fc.Count
    Next f1

Application.StatusBar = False
End Sub

Function TransposeDim(v As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)

    Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
    Dim tempArray As Variant

    Xupper = UBound(v, 2)
    Yupper = UBound(v, 1)

    ReDim tempArray(Xupper, Yupper)
    For X = 0 To Xupper
        For Y = 0 To Yupper
            tempArray(X, Y) = v(Y, X)
        Next Y
    Next X

    TransposeDim = tempArray

End Function

Public Function LastRow(ByVal rng As Range) As Long
'The most accurate method to return last used row in a range.
On Error GoTo blankSheetError
    'Identify next blank row
    LastRow = rng.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row

    'On Error GoTo 0 'not really needed
    Exit Function

blankSheetError:
    LastRow = 2 'Will produce error if blank sheet so default to row 2 as cannot have row 0
    Resume Next

End Function