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

VBA - 获取必要信息后关闭工作簿

2 个答案: