ランタイムエラー '9'下付き文字範囲外

Question

私はいくつかのExcelファイルを開き、それらのファイルからデータをコピーし、「Consolidated」という名前のシートにマクロファイルに貼り付ける必要があるマクロを持っています。 マクロは指定されたパスに移動し、フォルダ内のファイル数をカウントしてループスルーしてファイルを開き、内容をコピーして保存して閉じます。

マクロは私のシステムでは完全に動作しますが、ユーザシステム上では動作しません。

ループ処理中に受け取ったエラーは、「ランタイムエラー '9'下付き文字が範囲外です」です。このエラーがポップアップ表示されている行は、私は上記の行の前と後...これに5秒の待機時間を追加したので、ファイルはコードの実行よりも遅く開くかもしれないと思った最初は

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

です役立たず。

コードがあなたの助けを事前に

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

私はあなたの推測ここで二つの問題

完全に私のシステムではなく、ユーザーのシステム上でマクロが実行

があるかもしれませんApplication.FileSearchがxl2007で廃止されたので、xl2003でこれを実行してください。だから、あなたのコードがすべてのマシンで動作するようにする代わりに、Dirのアプローチを使用することをお勧めします。 xl2003を使用しているすべてのユーザーですか？

あなたは範囲

のうちのxl2007/10

私はループ処理中に受け付けており誤差がある「ランタイムエラー 『9』添字にエラー「オブジェクトはこのアクションをサポートしていません」を取得します

このエラーは、マシン上、またはユーザマシンの1つまたはすべてで発生していますか？

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 

これは、周囲の最もクリーンなコードの1つではないかもしれませんが、それは仕事を完了します。この問題に悩まされている人にとって、これはこの問題を回避する方法の1つです。これを行うより良い方法を知っている人のために、あなたのコードで回答してください。

私に手伝ってくれてありがとう!!!!