运行时错误'9'下标超出范围
我有一个macros，需要打开几个Excel文件，并从这些文件复制数据，并将其粘贴到名为“合并”表中的macros文件。 macros到指定的path，统计文件夹中的文件数，然后循环打开文件，复制内容，然后保存并closures文件。
macros在我的系统上完美运行，但不在用户系统上运行。
我在循环过程中收到的错误是“运行时错误”9“下标超出范围”。 这个错误popup的行是
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
在此先感谢您的帮助。
首先，确保你有
Option Explicit
在你的代码的顶部，所以你可以确保你不会混淆你的任何variables。 这样，在你的程序开始时，所有的东西都被标注了。 此外，使用variables为您的工作簿，它会清理代码，使其更容易理解，也使用缩进。
这工作对我来说，我发现我需要确保该文件尚未打开（假设您没有使用加载项），所以当您不想打开工作簿中的代码时已经打开）：
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
这里可能有两个问题
macros在我的系统上完美运行，但不在用户系统上运行
我认为你在xl2003运行这个Application.FileSearch在xl2007中被弃用。 因此，build议您最好使用Dir方法，以确保您的代码在所有机器上都能正常工作。 你用户全部使用xl2003吗？
您将在xl2007 / 10中得到“对象不支持此操作”的错误
我在循环过程中收到错误是“运行时错误'9'下标超出范围
这个错误发生在你的机器上，还是在一个/所有的用户机器上？
好了朋友们，
我终于弄清楚了这个问题。
发生此错误是因为原始数据文件夹中的某些文件已损坏并自动locking。 所以当macros打开文件得到一个错误，并在那里停止。
我现在已经改变了macros观。 现在将首先检查文件是否都可以导入。 如果存在损坏的文件，则会列出其名称，并且用户将被要求手动打开它，然后执行“另存为”并保存新版本的损坏文件，然后将其删除。
一旦完成，macros就会导入数据。
我正在放下下面的代码来testing损坏的文件。
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
这可能不是最干净的代码之一，但它完成了工作。 对于那些一直困扰这个问题的人来说，这是解决这个问题的方法之一。 对于那些更好的方式做这个请用您的代码回应。
感谢所有帮助我！