VBA，循环目录崩溃excel

我得到了下面的代码，它在目录中循环并执行高级筛选。 最多可以处理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

---

不确定这是否是您发布错误消息的原因，但这部分代码可能有问题：

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）时将出现错误

不确定这是否是您发布错误消息的原因，但这部分代码可能有问题：

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）时将出现错误

你确定是因为文件的数量吗？可能是一个格式错误的文件或文件名中的特殊字符？@Marc，很好的一点，是否需要手动检查其他文件？您确定这是由于文件数的原因吗？可能是一个格式不正确的文件或文件名中的特殊字符？@Marc，好的，有没有其他方法可以手动检查？dam，可能是真的，我如何解决这个问题，这取决于宏的用途。一种可能性是首先验证wksSummary的最后一行。如果工作表填写完整，创建一个新的工作表（“唯一数据2”）并从那里继续。我感到困惑，这似乎是一个复杂的问题。所以试着运行它，但创建一个新的工作表？dam，可能是真的，我如何修复它，这取决于宏的用途。一种可能性是首先验证wksSummary的最后一行。如果工作表填写完整，创建一个新的工作表（“唯一数据2”）并从那里继续。我感到困惑，这似乎是一个复杂的问题。所以试着运行它，但创建一个新的工作表？