搜索工作簿並提取數據而不打開Excel VBA

Question

我有一些vba代碼可以根據文件名日期（例如“ test-09Sep2016.xlsm”）打開excel文件。

打開文件后，它將在工作簿中搜索並嘗試查找我要查找的內容。 返回結果后，它將關閉工作簿並在文件夾中循環查找下一個文件，依此類推。

問題是文件很大，打開文件要花很長時間，我想知道是否有一種方法可以不打開實際文件。

我當前的代碼如下：

Sub firstCoord()

Dim fpath As String, fname As String
Dim dateCount As Integer, strDate As Date
Dim i As Integer, j As Integer, k As Integer, lastRow As Integer, lastRow2 As Integer
Dim ws As Worksheet, allws As Worksheet
Dim seg As String
Dim strNum As String
Dim strRow As Integer


lastRow = Sheet1.Range("A" & Sheet1.Rows.Count).End(xlUp).Row
seg = Mid(ThisWorkbook.Name, 34, 1)

With Application.WorksheetFunction

For i = 2 To lastRow

    fpath = "_______\"
    strDate = Sheet1.Range("B" & i)
    strNum = seg & Format(Mid(Sheet1.Range("A" & i), 4, 3), "000") & "000"

    dateCount = 0

    Do While Len(Dir(fpath & "_____-" & Format(strDate - dateCount, "ddmmmyyyy") & ".xlsx")) = 0 And dateCount < 35
    dateCount = dateCount + 1
    Loop

    fname = "____-" & Format(strDate - dateCount, "ddmmmyyyy") & ".xlsx"

    Workbooks.Open (fpath & fname)

    For Each ws In Workbooks(fname).Worksheets
        If ws.Name Like "*all*" Then
            Set allws = Workbooks(fname).Worksheets(ws.Name)
            ws.Activate
        End If
    Next ws

    lastRow2 = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).Row


    ThisWorkbook.Activate



    k = 1
    Do While (.CountIf(Sheet1.Range("C" & i & ":" & "E" & i), "") <> 0 Or Sheet1.Range("F" & i) = "") And k <= lastRow2


        If Left(allws.Range("A" & k), 7) = strNum Then
            Sheet1.Range("C" & i) = allws.Range("D" & k)
            Sheet1.Range("D" & i) = allws.Range("C" & k)
            Sheet1.Range("E" & i) = allws.Range("E" & k)
        ElseIf k = lastRow2 And Sheet1.Range("C" & i) = "" Then
            Sheet1.Range("F" & i) = "Not Found"

        End If

        k = k + 1

    Loop



    Workbooks(fname).Close


Next i


End With

End Sub

任何幫助將不勝感激！！

謝謝

Answer 1

可以使用adodb從Excel中檢索數據而無需打開文件，但就我所知，您必須至少了解目標文件中數據集的第一列/行和最后一列。 您不需要知道最后一行。

例如，此代碼調用兩個獨立的過程，一個過程從一個封閉的名為GetDataInClosedWB工作簿中返回一個單元格的值，一個過程返回定義范圍內第一個單元格的值：

Sub Main()
    Call GetDataFromSingleCell("A1")
    Call GetDataFromRangeBlock("A2", "D")
End Sub
Sub GetDataFromSingleCell(cell As String)

    Dim CN As Object ' ADODB.Connection
    Dim RS As Object ' ADODB.Recordset

    Set CN = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")

        CN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & CStr("C:\Users\USERNAME\Desktop\GetDataInA1.xlsx") & _
                ";" & "Extended Properties=""Excel 12.0;HDR=No;"";"
    RS.Open "SELECT * FROM [Sheet1$" & cell & ":" & cell & "];", CN, 3, 1  'adOpenStatic, adLockReadOnly


    MsgBox (RS.Fields(0).Value)
End Sub
Sub GetDataFromRangeBlock(firstCell As String, lastCol As String)
    'firstCell is the upper leftmost cell in the target range
    'lastCol is the column reference (e.g. A,B,C,D...) of the last column in the 
    'target dataset

    Dim CN As Object ' ADODB.Connection
    Dim RS As Object ' ADODB.Recordset

    Set CN = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")

    CN.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
             "Data Source=" & CStr("C:\Users\USERNAME\Desktop\GetDataInA1.xlsx") & _
             ";" & "Extended Properties=""Excel 12.0;HDR=No;"";"
    RS.Open "SELECT * FROM [Sheet1$" & firstCell & ":" & lastCol & "];", CN, 3, 1  'adOpenStatic, adLockReadOnly


    MsgBox (RS.Fields(0).Value)
End Sub

GetDataInClosedWB文件的值是Hello World! 在A1中，值FirstHeader ， SecondHeader ， ThirdHeader和FourthHeader在范圍A2：D2中。 第一個過程返回Hello World! 在消息框中，第二個在消息框中返回FirstHeader 。

一旦將數據加載到Recordset ，就可以遍歷數據並執行邏輯。

注意：如果您希望早期綁定，則需要啟用對Microsoft ActiveX數據對象庫的引用。