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

Question

I have a macro that needs to open a few excel files and copy data from those files and paste them into the macro file in a sheet named "Consolidated". The macro goes to a specified path, counts the number of files in the folder and then loops through to open a file, copy the contents and then save and close the file.

The macro runs perfectly on my system but not on the users systems.

The error i am receiving during the looping process is "Runtime Error '9' Subscript out of range". The line on which this error pops up is

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

At first i thought that the files might be opening slower than the code execution so i added wait time of 5 seconds before and after the above line...but to no avail.

The code is listed below

    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

Thanks in advance for your help.

Answer 1

First off, make sure you have

Option Explicit

at the top of your code so you can make sure you don't mess any of your variables up. This way, everything is dimensioned at the beginning of your procedure. Also, use variables for your workbooks, it'll clean up the code and make it more understandable, also, use indenting.

This worked for me, I found that I need to make sure the file isn't already open (assuming you aren't using an add-in) so you don't want to open the workbook with the code in it when it is already open):

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

Hope that helps.

Try this (hope I didn't mess any of it up), basically, I'm checking to make sure the directory exists also, and I cleaned up the code quite a bit to make it more understandable (mainly for myself):

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

There may be two issues here

The macro runs perfectly on my system but not on the users systems

I presume you are running this in xl2003 as Application.FileSearch was deprecated in xl2007. So you are probably best advised to use a Dir approach instead to ensure your code works on all machines. Are you users all using xl2003?

You will get a "Object doesn't support this action" error in xl2007/10

The error i am receiving during the looping process is "Runtime Error '9' Subscript out of range

Is this error occuring on your machine, or on one/all of the user machines?

Answer 3

Ok guys,

I have finally been able to figure out the problem.

This error is occuring because some of the files in the raw data folder are corrupted and get locked automatically. So when the macro on opening the file gets an error and stops there.

I have now made a change to the macro. It would now first check if the files are all ok to be imported. If there is a corrupt file then it would list down their names and the user will be required to manually open it and then do a "save As" and save a new version of the corrupt file and then delete it.

Once this is done then the macro does the import of the data.

I am putting down the code below for testing the corrupt files.

    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

This may not be one of the cleanest codes around, but it gets the job done. For those who have been troubled by this problem this is one of the ways to get around this problem. For those who havae a better way of doing this please respond with your codes.

Thanks to all for helping me out!!!!