VBA，通过目录循环崩溃Excel

Question

I got the following code that loops through a directory and does an advanced filter. Works fine on maybe up to 20 files, when I get to 50+ files, I run into issues "Method 'Open' of object 'workbooks' failed". Could it just be the size of these files to large?

Any help would be appreciated. This is the debug line , which may be about my function module:

      Set wb = Workbooks.Open(fileNames(Key))

Here is my full code:

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

Here is my 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

Answer 1

Not sure if this is the cause of the error message you posted, but this part of your code could be a problem:

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

If wksSummary has its third column all filled out, there will be an error when you offset(1,0).