运行时错误'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 

这可能不是最干净的代码之一，但它可以完成工作。对于那些一直困扰这个问题的人来说，这是解决这个问题的方法之一。对于那些喜欢这样做的更好的方式，请使用您的代码进行回复。

感谢所有帮助我！