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中运行它，因为在xl2007中不推荐使用Application.FileSearch。因此，最好建议您使用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

这可能不是最干净的代码之一，但它完成了工作。对于那些一直困扰这个问题的人来说，这是解决这个问题的方法之一。对于那些采用更好方法的人，请回复您的密码。

感谢所有人帮助我!!!!

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

3 个答案: