运行时错误'9'下标超出范围

Question

我有一个宏，需要打开一些excel文件并从这些文件中复制数据，然后将它们粘贴到名为“ Consolidated”的工作表中的宏文件中。 宏转到指定的路径，计算文件夹中文件的数量，然后循环打开以打开文件，复制内容，然后保存并关闭文件。

该宏可以在我的系统上完美运行，但不能在用户系统上运行。

我在循环过程中收到的错误是“运行时错误'9'下标超出范围”。 弹出此错误的行是

    Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))

起初我以为文件的打开速度可能比代码执行慢，所以我在上述行之前和之后增加了5秒的等待时间...但无济于事。

该代码在下面列出

    Sub grab_data()
    Application.ScreenUpdating = False
    Dim rng As Range

    srow = ThisWorkbook.Sheets("Consolidated Data").Cells(65536, 11).End(xlUp).Row


    'Number of filled rows in column A of control Sheet
    ThisWorkbook.Sheets("Control Sheet").Activate
    rawfilepth = Sheets("Control Sheet").Cells(65536, 1).End(xlUp).Row

    'Loop to find the number of excel files in the path in each row of the Control Sheet
    For folder_count = 2 To rawfilepth
    wkbpth = Sheets("Control Sheet").Cells(folder_count, 1).Value
    With Application.FileSearch
    .LookIn = wkbpth
    .FileType = msoFileTypeExcelWorkbooks
    .Execute
    filecnt = .FoundFiles.Count

    'Loop to count the number of sheets in each file
    For file_count = 1 To filecnt
    Application.Wait (Now + TimeValue("0:00:05"))
    Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))
    Application.Wait (Now + TimeValue("0:00:05"))
    filenm = ActiveWorkbook.Name
    For sheet_count = 1 To Workbooks(filenm).Sheets.Count
    If Workbooks(filenm).Sheets(sheet_count).Name <> "Rejected" Then
        Workbooks(filenm).Sheets(sheet_count).Activate
        ActiveSheet.Columns("a:at").Select
        Selection.EntireColumn.Hidden = False
        shtnm = Trim(ActiveSheet.Name)
        lrow = ActiveSheet.Cells(65536, 11).End(xlUp).Row
        If lrow = 1 Then lrow = 2

    For blank_row_count = 2 To lrow
    If ActiveSheet.Cells(blank_row_count, 39).Value = "" Then
    srow = ActiveSheet.Cells(blank_row_count, 39).Row
    Exit For
    End If
    Next blank_row_count

    For uid = srow To lrow
    ActiveSheet.Cells(uid, 40).Value = ActiveSheet.Name & uid
    Next uid

        ActiveSheet.Range("a" & srow & ":at" & lrow).Copy
        ThisWorkbook.Sheets("Consolidated Data").Activate
        alrow = ThisWorkbook.Sheets("Consolidated Data").Cells(65536, 11).End(xlUp).Row
        ThisWorkbook.Sheets("Consolidated Data").Range("a" & alrow + 1).Activate
        ActiveCell.PasteSpecial xlPasteValues
        ThisWorkbook.Sheets("Consolidated Data").Range("z" & alrow + 1).Value = shtnm
        ThisWorkbook.Sheets("Consolidated Data").Range("z" & alrow + 1 & ":z" & (alrow+lrow)).Select
        Selection.FillDown
        ThisWorkbook.Sheets("Consolidated Data").Range("ap" & alrow + 1).Value = wkbpth
        ThisWorkbook.Sheets("Consolidated Data").Range("ap" & alrow + 1 & ":ap" & (alrow + lrow)).Select
        Selection.FillDown
        ThisWorkbook.Sheets("Consolidated Data").Range("ao" & alrow + 1).Value = filenm
        ThisWorkbook.Sheets("Consolidated Data").Range("ao" & alrow + 1 & ":ao" & (alrow + lrow)).Select
        Selection.FillDown

        Workbooks(filenm).Sheets(sheet_count).Activate
        ActiveSheet.Range("am" & srow & ":am" & lrow).Value = "Picked"
        ActiveSheet.Columns("b:c").EntireColumn.Hidden = True
        ActiveSheet.Columns("f:f").EntireColumn.Hidden = True
        ActiveSheet.Columns("h:i").EntireColumn.Hidden = True
        ActiveSheet.Columns("v:z").EntireColumn.Hidden = True
        ActiveSheet.Columns("aa:ac").EntireColumn.Hidden = True
        ActiveSheet.Columns("ae:ak").EntireColumn.Hidden = True
        End If
    Next sheet_count
Workbooks(filenm).Close True
Next file_count
    End With
Next folder_count
Application.ScreenUpdating = True
End Sub

在此先感谢您的帮助。

Answer 1

首先，请确保您有

Option Explicit

在代码的顶部，这样可以确保您不会弄乱任何变量。 这样，一切都会在过程开始时确定大小。 另外，在您的工作簿中使用变量，它将清理代码并使代码更易于理解，还可以使用缩进。

这对我有用，我发现我需要确保该文件尚未打开（假设您没有使用加载项），因此您不想打开包含代码的工作簿。已经打开）：

Sub grab_data()

    Dim wb As Workbook, wbMacro As Workbook
    Dim filecnt As Integer, file_count As Integer

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Set wbMacro = ThisWorkbook

    With Application.FileSearch
        .LookIn = wbMacro.Path
        .FileType = msoFileTypeExcelWorkbooks
        .Execute
        filecnt = .FoundFiles.Count

        'Loop to count the number of sheets in each file
        For file_count = 1 To filecnt

            If wbMacro.FullName <> .FoundFiles(file_count) Then
                Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))
                Debug.Print wb.Name
                wb.Close True
            End If

        Next file_count
    End With

    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

希望能有所帮助。

试试这个（希望我没有弄乱任何东西），基本上，我正在检查以确保目录也存在，并且我整理了一些代码以使其更易于理解（主要是为我自己）：

Sub grab_data()

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Dim i As Long
    Dim lRow As Long, lRowEnd As Long, lFolder As Long, lFilesTotal As Long, lFile As Long
    Dim lUID As Long
    Dim rng As Range
    Dim sWkbPath As String
    Dim wkb As Workbook, wkbTarget As Workbook
    Dim wksConsolidated As Worksheet, wks As Worksheet
    Dim v1 As Variant

    Set wkb = ThisWorkbook
    Set wksConsolidated = wkb.Sheets("Consolidated Data")

    'Loop to find the number of excel files in the path in each row of the Control Sheet
    For lFolder = 2 To wksConsolidated.Cells(65536, 1).End(xlUp).Row

        sWkbPath = wksConsolidated.Cells(lFolder, 1).Value
        'Check if file exists
        If Not Dir(sWkbPath, vbDirectory) = vbNullString Then
            With Application.FileSearch
                .LookIn = sWkbPath
                .FileType = msoFileTypeExcelWorkbooks
                .Execute
                lFilesTotal = .FoundFiles.Count
                'Loop to count the number of sheets in each file
                For lFile = 1 To lFilesTotal
                    If .FoundFiles(lFile) <> wkb.FullName Then
                        Set wkbTarget = Workbooks.Open(Filename:=.FoundFiles(lFile))
                        For Each wks In wkbTarget.Worksheets
                            If wks.Name <> "Rejected" Then
                                wks.Columns("a:at").EntireColumn.Hidden = False
                                lRowEnd = Application.Max(ActiveSheet.Cells(65536, 11).End(xlUp).Row, 2)
                                v1 = Application.Transpose(wks.Range(Cells(2, 39), Cells(lRowEnd, 39)))
                                For i = 1 To UBound(v1)
                                    If Len(v1(i)) = 0 Then
                                        lRow = i + 1
                                        Exit For
                                    End If
                                Next i
                                v1 = Application.Transpose(wks.Range(Cells(lRow, 40), Cells(lRowEnd, 40)))
                                For lUID = 1 To UBound(v1)
                                    v1(lUID) = wks.Name & lUID
                                Next lUID
                                Application.Transpose(wks.Range(Cells(lRow, 40), Cells(lRowEnd, 40))) = v1
                                wks.Range("a" & lRow & ":at" & lRowEnd).Copy
                                i = wksConsolidated.Cells(65536, 11).End(xlUp).Row
                                With wksConsolidated
                                    .Range("A" & i).PasteSpecial xlPasteValues
                                    Application.CutCopyMode = False
                                    .Range("z" & i + 1).Value = wks.Name
                                    .Range("z" & i + 1 & ":z" & i + lRowEnd).FillDown
                                    .Range("ap" & i + 1) = sWkbPath
                                    .Range("ap" & i + 1 & ":ap" & i + lRowEnd).FillDown
                                    .Range("ao" & i + 1) = wkbTarget.FullName
                                    .Range("ao" & i + 1 & ":ao" & (i + lRowEnd)).FillDown
                                End With
                                With wks
                                    .Range("am" & lRow & ":am" & lRowEnd) = "Picked"
                                    .Columns("b:c").EntireColumn.Hidden = True
                                    .Columns("f:f").EntireColumn.Hidden = True
                                    .Columns("h:i").EntireColumn.Hidden = True
                                    .Columns("v:z").EntireColumn.Hidden = True
                                    .Columns("aa:ac").EntireColumn.Hidden = True
                                    .Columns("ae:ak").EntireColumn.Hidden = True
                                End With
                            End If
                        Next wks
                        wkbTarget.Close True
                    End If
                Next lFile
            End With
        End If
    Next lFolder

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Answer 2

这里可能有两个问题

该宏可以在我的系统上完美运行，但不能在用户系统上运行

我假设您在xl2003中运行此程序，因为Application.FileSearch在xl2007中已弃用。 因此，最好建议您改用Dir方法，以确保您的代码可在所有计算机上使用。 您是否都在使用xl2003？

xl2007 / 10中将出现“对象不支持此操作”错误

我在循环过程中收到的错误是“运行时错误'9'下标超出范围”

是您的计算机上还是一台/所有用户计算机上发生此错误？

Answer 3

好了朋友们，

我终于能够找出问题所在。

发生此错误是因为原始数据文件夹中的某些文件已损坏并自动被锁定。 因此，当打开文件的宏出现错误并在那里停止。

我现在对宏进行了更改。 现在它将首先检查文件是否都可以导入。 如果存在损坏的文件，则它将列出其名称，并且要求用户手动打开它，然后执行“另存为”并保存损坏文件的新版本，然后将其删除。

完成此操作后，宏将导入数据。

我放下下面的代码来测试损坏的文件。

    Sub error_tracking()
    Dim srow As Long
    Dim rawfilepth As Integer
    Dim folder_count As Integer
    Dim lrow As Long
    Dim wkbpth As String
    Dim alrow As Long
    Dim One_File_List As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ThisWorkbook.Sheets("Control Sheet").Activate
    rawfilepth = Sheets("Control Sheet").Cells(65536, 1).End(xlUp).Row
    Sheets("Control Sheet").Range("E2:E100").Clear
    'Loop to find the number of excel files in the path
    'in each row of the Control Sheet

    For folder_count = 2 To rawfilepth
       wkbpth = Sheets("Control Sheet").Cells(folder_count, 1).Value
       One_File_List = Dir$(wkbpth & "\*.xls")

       Do While One_File_List <> ""

           On Error GoTo err_trap
           Workbooks.Open wkbpth & "\" & One_File_List

      err_trap:
          If err.Number = "1004" Then
              lrow = Sheets("Control Sheet").Cells(65536, 5).End(xlUp).Row
              Sheets("Control Sheet").Cells(lrow + 1, 5).Value = One_File_List
          Else
              Workbooks(One_File_List).Close savechanges = "No"
          End If

     One_File_List = Dir$
     Loop

   Next folder_count

     If Sheets("Control Sheet").Cells(2, 5).Value = "" Then
        Call grab_data
     Else
        MsgBox "Please check control sheet for corrupt file names.", vbCritical, "Corrupt Files  Notification"
    End If

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True


    End Sub

这可能不是最干净的代码之一，但是可以完成工作。 对于那些受到此问题困扰的人，这是解决此问题的方法之一。 对于那些拥有更好方法的人，请提供您的代码。

谢谢大家的帮助！！！！