VBA - 獲取必要信息后關閉工作簿

Question

解決此問題（Excel VBA）問題需要您的幫助。 我正在使用VBA來填充一個巨大的工作簿（每行500個單元），從一堆工作簿（Qty = 96）。 我使用的VBA是由[@Kevin] [1]創建的，它適用於大約20個文件，直到我的電腦內存耗盡並崩潰Excel。 這種工作非常適合每個工作簿使用如此龐大的單元格，因為打開和關閉每個工作簿會使這個過程相當多。 打開每個工作簿並復制所有500個單元格並關閉，然后繼續下一個，依此類推x±96次，但這比僅僅使這個工作更復雜，如果您有任何2個解決方案請幫助！

這是我正在使用的VBA：

Function GetField(Path As String, WorksheetName As String, CellRange As String) As Variant

Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range

Set wb = GetObject(Path)
Set ws = wb.Worksheets(WorksheetName)
Set rng = ws.Range(CellRange)

GetField = rng.Value

wb.close 

End Function

Answer 1

更新的答案

要回答原始問題，必須先激活工作簿，然后關閉活動工作簿。 但是，在函數中執行此操作是非常差的實踐，並且很可能以非直觀的方式執行。

以下是對原始代碼的修復：

Function GetField(Path As String, WorksheetName As String, CellRange As String) As Variant

    'code

    wb.Activate 'Activate the opened workbook
    ActiveWorkbook.Saved = True
    ActiveWorkbook.Close 'Close the active workbook

End Function

不建議在函數內執行.Close 。

相反，為了實現同樣的目的而不必擔心，請創建一個Sub來關閉由您的函數打開的工作簿。 我們可以通過以下方式實現這一目標：

Sub closeWB(Path As String)
    Dim wb As Workbook
    Set wb = GetObject(Path)
    wb.Activate
    ActiveWorkbook.Saved = True
    ActiveWorkbook.Close
End Sub

然后從您調用函數的同一個地方調用它。 只需將其放在函數調用之后..

Sub YourMainSub()
    Path = "C:\Users\you\Desktop\file example.xlsm"
    something.GetField(Path, "Sheet 1", "A1")
    Call closeWB(Path)
End Sub

經過Allan和我之間的大量討論，我們發現了他的問題的解決方案。 最終在工作表上使用UDF無法滿足他的需求。 因此，我們改變了方向並制定了一個基本上做同樣事情的例程，但沒有工作表函數。 這不僅減小了文件大小，還使得導入數據和設置數據導入的速度明顯加快。 下面是一個示例摘錄，以防任何有同樣問題的人想要第二個可能表現更好的選項。

我可以將數據導入（我們Call DataLoop() ）放在它自己的For循環中，但選擇不這樣做，因為維護一個簡單易於編輯的代碼比視覺效率更重要。

'The function that imports the data
Public Function GetField(Path, file, WorksheetName, CellRange) As Variant
   Dim wb As Workbook, ws As Worksheet, rng As Range, field As String

   If Right(Path, 1) <> "\" Then Path = Path & "\"

   If Dir(Path & file) = "" Then
       GetField = "File Not Found"
       Exit Function
   End If

   field = "'" & Path & "[" & file & "]" & WorksheetName & "'!" & Range(CellRange).Range("A1").Address(ReferenceStyle:=xlR1C1)
   GetField = ExecuteExcel4Macro(field)
End Function

'A loop that calls on the function
Sub DataLoop(DataRange As Range, SourceRow As Long, SourceColumn As Integer, Path, file, WorksheetName)
    Dim rcell

    For Each rcell In DataRange
        rcell.Value = GetField(Path, file, WorksheetName, Cells(SourceRow, SourceColumn).Address(RowAbsolute:=False, ColumnAbsolute:=False))
        SourceColumn = SourceColumn + 1
    Next rcell
End Sub

'The main routine where we define where data goes and comes from
Sub DataEntry()
    Dim dataWS As Worksheet, Path1 As String, WsName1 As String

    Dim testFileName As Range, file

    Dim avgDmmV As Range, avgPSTATADCV As Range, ppPSTATADCV As Range

    Dim gainLO0A As Range, gainLO0B As Range, gainLOm10A As Range, gainLOm10B As Range
    Dim gainLO10A As Range, gainLO10B As Range, gainLO20A As Range, gainLO20B As Range
    Dim gainLO60A As Range, gainLO60B As Range

    Set dataWS = ThisWorkbook.Sheets("DATA")
    Path1 = "\\server5\Operations\MainBoard testing central location DO NOT REMOVE or RENAME" 'File path Location
    WsName1 = "Summary"

    'The values of the cells in this range have the names of the .xls files
    Set testFileName = dataWS.Range("A6", dataWS.Range("A6").End(xlDown)) 

    For Each file In testFileName 'Loop through each file name
        dataRow = file.Row

        Set avgDmmV = dataWS.Range("C" & dataRow & ":F" & dataRow)
        Set avgPSTATADCV = dataWS.Range("H" & dataRow & ":M" & dataRow)
        Set ppPSTATADCV = dataWS.Range("Q" & dataRow & ":W" & dataRow)

        Set gainLO0A = dataWS.Range("Y" & dataRow & ":AG" & dataRow)
        Set gainLO0B = dataWS.Range("AI" & dataRow & ":AQ" & dataRow)
        Set gainLOm10A = dataWS.Range("AS" & dataRow & ":BA" & dataRow)
        Set gainLOm10B = dataWS.Range("BC" & dataRow & ":BK" & dataRow)
        Set gainLO10A = dataWS.Range("BM" & dataRow & ":BU" & dataRow)
        Set gainLO10B = dataWS.Range("BW" & dataRow & ":CE" & dataRow)
        Set gainLO20A = dataWS.Range("CG" & dataRow & ":CO" & dataRow)
        Set gainLO20B = dataWS.Range("CQ" & dataRow & ":CY" & dataRow)
        Set gainLO60A = dataWS.Range("DA" & dataRow & ":DI" & dataRow)
        Set gainLO60B = dataWS.Range("DK" & dataRow & ":DS" & dataRow)

        Call DataLoop(avgDmmV, 9, 5, Path1, CStr(file.Value), WsName1)
        Call DataLoop(avgPSTATADCV, 15, 5, Path1, CStr(file.Value), WsName1)
        Call DataLoop(ppPSTATADCV, 18, 5, Path1, CStr(file.Value), WsName1)

        Call DataLoop(gainLO0A, 31, 3, Path1, CStr(file.Value), WsName1)
        Call DataLoop(gainLO0B, 32, 3, Path1, CStr(file.Value), WsName1)
        Call DataLoop(gainLOm10A, 33, 3, Path1, CStr(file.Value), WsName1)
        Call DataLoop(gainLOm10B, 34, 3, Path1, CStr(file.Value), WsName1)
        Call DataLoop(gainLO10A, 35, 3, Path1, CStr(file.Value), WsName1)
        Call DataLoop(gainLO10B, 36, 3, Path1, CStr(file.Value), WsName1)
        Call DataLoop(gainLO20A, 37, 3, Path1, CStr(file.Value), WsName1)
        Call DataLoop(gainLO20B, 38, 3, Path1, CStr(file.Value), WsName1)
        Call DataLoop(gainLO60A, 39, 3, Path1, CStr(file.Value), WsName1)
        Call DataLoop(gainLO60B, 40, 3, Path1, CStr(file.Value), WsName1)
    Next file
End Sub

Answer 2

那么如何使用ADO查詢excel文件呢？

Function getField(Path As String, WorksheetName As String, CellRange As String) As Variant
    Const adOpenStatic = 3
    Const adLockOptimistic = 3
    Const adCmdText = &H1

    Set objConnection = CreateObject("ADODB.Connection")
    Set objRecordset = CreateObject("ADODB.Recordset")

    objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & Path & ";" & _
            "Extended Properties=""Excel 8.0;HDR=NO;"";"

    objRecordset.Open "Select F" & Range(CellRange).Column & " as Val  FROM [" & WorksheetName & "$]", _
        objConnection, adOpenStatic, adLockOptimistic, adCmdText

    objRecordset.Move Range(CellRange).Row - 1

    getField = objRecordset("Val")

    objRecordset.Close
    objConnection.Close
End Function