VBA，循环目录崩溃的Excel
我得到了下面的代码循环通过一个目录，并进行高级filter。 可能多达20个文件工作正常，当我得到50 +文件，我遇到的问题“方法”打开“对象”工作簿“失败”。 难道这只是这些文件的大小？
任何帮助，将不胜感激。 这是debugging行，这可能是关于我的function模块：
Set wb = Workbooks.Open(fileNames(Key)) 这是我的完整代码：
Sub Stackoverflow() Dim wb As Workbook, fileNames As Object, errCheck As Boolean Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet Dim y As Range, intRow As Long, i As Integer Dim r As Range, lr As Long, myrg As Range, z As Range Dim boolWritten As Boolean, lngNextRow As Long Dim intColNode As Integer, intColScenario As Integer Dim intColNext As Integer, lngStartRow As Long Dim lngLastNode As Long, lngLastScen As Long ' Turn off screen updating and automatic calculation With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With ' Create a new worksheet, if required On Error Resume Next Set wksSummary = ActiveWorkbook.Worksheets("Unique data") On Error GoTo 0 If wksSummary Is Nothing Then Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count)) wksSummary.Name = "Unique data" End If ' Set the initial output range, and assign column headers With wksSummary Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0) Set r = y.Offset(0, 1) Set z = y.Offset(0, -2) lngStartRow = y.Row .Range("A1:D1").Value = Array("File Name", "Sheet Name", "Node Name", "Scenario Name") End With 'get user input for files to search Set fileNames = CreateObject("Scripting.Dictionary") errCheck = UserInput.FileDialogDictionary(fileNames) If errCheck Then Exit Sub End If ''' For Each Key In fileNames 'loop through the dictionary Set wb = Workbooks.Open(fileNames(Key)) wb.Application.Visible = False 'make it not visible ' Check each sheet in turn For Each ws In ActiveWorkbook.Worksheets With ws ' Only action the sheet if it's not the 'Unique data' sheet If .Name <> wksSummary.Name Then boolWritten = False ' Find the Scenario column intColScenario = 0 On Error Resume Next intColScenario = WorksheetFunction.Match("scenarioName", .Rows(1), 0) On Error GoTo 0 If intColScenario > 0 Then ' Only action if there is data in column E If Application.WorksheetFunction.CountA(.Columns(intColScenario)) > 1 Then ' Find the next free column, in which the extract formula will be placed intColNext = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1 ' Assign formulas to the next free column to identify the scenario name to the left of the first _ character .Cells(1, intColNext).Value = "Test" lr = .Cells(.Rows.Count, intColScenario).End(xlUp).Row Set myrg = .Range(.Cells(2, intColNext), .Cells(lr, intColNext)) With myrg .ClearContents .FormulaR1C1 = "=IFERROR(LEFT(RC" & intColScenario & ",FIND(INDEX({""+"",""-"",""_"",""$"",""%""},1,MATCH(1,--(ISNUMBER(FIND({""+"",""-"",""_"",""$"",""%""},RC" & _ intColScenario & "))),0)), RC" & intColScenario & ")-1), RC" & intColScenario & ")" .Value = .Value End With ' Copy unique values from the formula column to the 'Unique data' sheet, and write sheet & file details .Range(.Cells(1, intColNext), .Cells(lr, intColNext)).AdvancedFilter xlFilterCopy, , r, True r.Offset(0, -2).Value = ws.Name r.Offset(0, -3).Value = ws.Parent.Name ' Clear the interim results .Range(.Cells(1, intColNext), .Cells(lr, intColNext)).ClearContents ' Delete the column header copied to the list r.Delete Shift:=xlUp boolWritten = True End If End If ' Find the Node column intColNode = 0 On Error Resume Next intColNode = WorksheetFunction.Match("node", .Rows(1), 0) On Error GoTo 0 If intColNode > 0 Then ' Only action if there is data in column A If Application.WorksheetFunction.CountA(.Columns(intColNode)) > 1 Then lr = .Cells(.Rows.Count, intColNode).End(xlUp).Row ' Copy unique values from column A to the 'Unique data' sheet, and write sheet & file details (if not already written) .Range(.Cells(1, intColNode), .Cells(lr, intColNode)).AdvancedFilter xlFilterCopy, , y, True If Not boolWritten Then y.Offset(0, -1).Value = ws.Name y.Offset(0, -2).Value = ws.Parent.Name End If ' Delete the column header copied to the list y.Delete Shift:=xlUp End If End If ' Identify the next row, based on the most rows used in columns C & D lngLastNode = wksSummary.Cells(wksSummary.Rows.Count, 3).End(xlUp).Row lngLastScen = wksSummary.Cells(wksSummary.Rows.Count, 4).End(xlUp).Row lngNextRow = WorksheetFunction.Max(lngLastNode, lngLastScen) + 1 If (lngNextRow - lngStartRow) > 1 Then ' Fill down the workbook and sheet names z.Resize(lngNextRow - lngStartRow, 2).FillDown If (lngNextRow - lngLastNode) > 1 Then ' Fill down the last Node value wksSummary.Range(wksSummary.Cells(lngLastNode, 3), wksSummary.Cells(lngNextRow - 1, 3)).FillDown End If If (lngNextRow - lngLastScen) > 1 Then ' Fill down the last Scenario value wksSummary.Range(wksSummary.Cells(lngLastScen, 4), wksSummary.Cells(lngNextRow - 1, 4)).FillDown End If End If Set y = wksSummary.Cells(lngNextRow, 3) Set r = y.Offset(0, 1) Set z = y.Offset(0, -2) lngStartRow = y.Row End If End With Next ws wb.Close savechanges:=False 'close the workbook do not save Set wb = Nothing 'release the object Next 'End of the fileNames loop Set fileNames = Nothing ' Autofit column widths of the report wksSummary.Range("A1:D1").EntireColumn.AutoFit ' Reset system settings With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True .Visible = True End With End Sub
这是我的function：
Function FileDialogDictionary(ByRef file As Object) As Boolean ' returns true if the user cancels 'Declare a variable as a FileDialog object. Dim fd As FileDialog Dim item As Variant Dim i As Long 'Create a FileDialog object as a File Picker dialog box. file.RemoveAll 'clear the dictionary Set fd = Application.FileDialog(msoFileDialogFilePicker) 'Declare a variable to contain the path 'of each selected item. Even though the path is a String, 'the variable must be a Variant because For Each...Next 'routines only work with Variants and Objects. 'Use a With...End With block to reference the FileDialog object. With fd 'Use the Show method to display the File Picker dialog box and return the user's action. 'The user pressed the action button. .Title = "Select Excel Workbooks" 'Change this to suit your purpose .AllowMultiSelect = True .Filters.Clear .Filters.Add "Microsoft Excel files", "*.xlsx,*.xls" If .Show = -1 Then 'Step through each string in the FileDialogSelectedItems collection. For Each item In .SelectedItems 'loop through all selected and add to dictionary i = i + 1 file.Add i, item Next item FileDialogDictionary = False 'The user pressed Cancel. Else FileDialogDictionary = True Set fd = Nothing Exit Function End If End With Set fd = Nothing 'Set the object variable to Nothing. End Function
不知道这是否是您发布的错误消息的原因，但是这部分代码可能是一个问题：
With wksSummary Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0) Set r = y.Offset(0, 1) Set z = y.Offset(0, -2) lngStartRow = y.Row .Range("A1:D1").Value = Array("File Name", "Sheet Name", "Node Name", "Scenario Name") End With
如果wksSummary的第三列全部填满，则在抵消（1,0）时将出现错误。