VBA – 获取必要信息后closures工作簿

解决这个世界（Excel VBA）问题需要您的帮助。 我正在使用VBA从工作簿的桶负载（Qty = 96）中填充巨大的工作簿（每行500个单元格）。 我正在使用的VBA是由[@Kevin] [1]创build的，它可以用于大约20个文件，直到我的电脑内存不足并崩溃Excel。 这种工作方式非常适合每个工作簿使用大量的单元格，因为打开和closures每个工作簿都会增加相当多的工作量。 打开每个工作簿，并复制所有500个单元格，然后closures，然后继续下一个工作，等等x±96次，但这将比只是这个工作更复杂，如果你有任何2个解决scheme，请帮助！

这里是我正在使用的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

更新的答案

要回答您原来的问题，您必须先激活工作簿，然后closures活动工作簿。 但是，在一个函数中这样做是非常糟糕的做法，而且很可能以非直观的方式执行。

以下是对原始代码的修复：

 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 

不build议在您的function中执行.Close 。

相反，为了实现同样的事情而不用担心，请使用Sub来closures由您的函数打开的工作簿。 我们可以通过以下做法来达到这个目的：

 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 

经过艾伦和我之间的很多讨论后，我们发现了一个解决他的问题。 最终在工作表上使用UDF不能满足他的需求。 因此，我们改变了方向，做了一个基本上做同样的事情，但没有工作表function的例程。 这不仅减less了文件的大小，而且使导入数据和设置数据导入速度明显加快。 下面是一个示例摘录，以防万一有这个相同问题的人想要第二个可能performance更好的选项。

我可以将数据导入（我们将Call DataLoop()到它自己的For循环中），但select不这样做，因为保持简单易于编辑的代码比视觉效率更重要。

 '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