2016-09-16 75 views
1

需要您的幫助來解決這個世界(Excel VBA)問題。 我正在使用VBA從工作簿的桶裝載(Qty = 96)中填充巨大的工作簿(每行500個單元格)。 我使用的VBA是由[@Kevin] [1]創建的,它可以用於大約20個文件,直到我的電腦內存不足並崩潰Excel。 這種工作方式非常適合每個工作簿使用大量的單元格,因爲打開和關閉每個工作簿都會增加過程。打開每個工作簿並複製所有500個單元並關閉,然後繼續下一個單元,等等x±96次,但這比僅僅完成這個工作更復雜,如果您有任何2個解決方案,請幫助!VBA - 獲取必要信息後關閉工作簿

這裏是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 
+1

您正在嘗試使用'Function',但在其中有'Application.Quit'。我不確定你是否可以這樣做。相反,把它變成一個'Sub'(你將不得不爲那些正在傳遞的變量創建變量),看看它是否有效。 – BruceWayne

+0

你永遠不會告訴它什麼工作簿關閉。 –

+0

@DougCoats,我也試過了。關閉 其中wb = GetObject(Path)或 GetObject(Path).Close SaveChanges:= True – Allan

回答

2

更新回答

要回答你原來的問題,你必須首先激活該工作簿,然後關閉活動工作簿。 然而,在一個函數中做這件事是非常糟糕的做法,並且很可能以非直觀的方式執行。

以下是修復到原始代碼:

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 

很多艾倫和我之間的討論後,我們發現了一個解決他的問題。最終在工作表上使用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 
+0

只是好奇 - 是否通常或建議在運行函數時關閉activeworkbook?有些事情聽起來像可能不被推薦......但我想這與在「Sub ...... .... hm」中關閉工作簿沒有什麼不同。 – BruceWayne

+2

@BruceWayne不,我從來沒有做過。嘗試做類似的事情似乎不是很好的編程習慣。 – Tyeler

+0

謝謝泰勒,這工作完全像我現在的代碼,你的幫助表示讚賞。 – Allan

1

那麼如何使用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 
相關問題