VBA, Loop через каталог crashing excel

Question

У меня есть следующий код, который проходит через каталог и имеет расширенный фильтр. Работает нормально, возможно, до 20 файлов, когда я попадаю в 50+ файлов, я сталкиваюсь с проблемами «Невозможно« Открыть »для« книг »объекта. Может ли это быть размером с этими файлами?

Любая помощь будет оценена по достоинству. Это отладочная линия, которая может быть о моей функции модуля:

 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 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 

Answer 1

Не уверен, что если это является причиной сообщения об ошибке, которое вы опубликовали, но эта часть вашего кода может быть проблемой:

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).