• 締切済み

Visual Basic Editorの実行時エラーのことについて教えてください。 

Visual Basic超初心者ですがよろしくお願いします。 標準モジュールで入力したものを実行すると、必ず「実行時エラー "53": ファイルが見つかりません。」と表示してしまいます。 入力したものはミスはないと思うのですが、何回やってもエラーが出てしまいます。 わかる方いましたら教えてください。 入力したものを一応載せときます↓ Sub list_file() Dim numfile As Long Dim i As Long With Application.FileSearch .NewSearch .LookIn = Range("b1").Value .Filename = Range("b2").Value .SearchSubFolders = Range("b3").Value If .Execute() > 0 Then file_count = .FoundFiles.Count MsgBox file_count & "files exis" Worksheets.Add after:=Worksheets("sheet1") Range("a1").Value = "filename" Range("b1").Value = "date" Range("c1").Value = "size" For i = 1 To file_count Cells(i + 1, 1).Value = .FoundFiles(i) Cells(i + 1, 2).Value = FileDateTime(.FoundFiles(i)) Cells(i + 1, 3).Value = FileLen(.FoundFiles(i)) Cells(i + 1, 2).Value = Hex(Cells(i + 1, 3).Value) Next Columns("a:c").AutoFit Else MsgBox "no file exists" End If End With End Sub

みんなの回答

回答No.2

Cells(i + 1, 2).Value = FileDateTime(.FoundFiles(i))でエラーになると言うことは、.Execute()の時点ではあるけど、Cells(i + 1, 2).Value = FileDateTime(.FoundFiles(i))の時には無いと言う事でしょうから、以下のようにしてはどうでしょう。 または、on error で飛ばす方法もあります。 Sub list_file() Dim numfile As Long Dim i As Long Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") With Application.FileSearch .NewSearch Sheets("sheet1").Select .LookIn = Range("b1").Value .Filename = Range("b2").Value .SearchSubFolders = Range("b3").Value If .Execute() > 0 Then file_count = .FoundFiles.Count MsgBox file_count & "files exis" Worksheets.Add after:=Worksheets("sheet1") Range("a1").Value = "filename" Range("b1").Value = "date" Range("c1").Value = "size" For i = 1 To file_count Cells(i + 1, 1).Value = .FoundFiles(i) If fso.FileExists(.FoundFiles(i)) = True Then Cells(i + 1, 2).Value = FileDateTime(.FoundFiles(i)) Cells(i + 1, 3).Value = FileLen(.FoundFiles(i)) Cells(i + 1, 4).Value = Hex(Cells(i + 1, 3).Value) Else Cells(i + 1, 5).Value = "削除されています" End If Next Columns("a:c").AutoFit Else MsgBox "no file exists" End If End With Set fso = Nothing End Sub p.s. office2007ではFileSearchが無くなっているらしいです。 http://support.microsoft.com/kb/935402/ja これからは、Dir 関数または FileSystemObjectを使った方がいいかもしれません。

回答No.1

検索条件を取得するsheetが不安定なんじゃないでしょうか? 検索条件がsheet1にある場合なら、最初にcellの値を取得する.LookIn = Range("b1").Valueの前に Sheets("sheet1").Select を入れてみてください。 複数のsheetや標準モジュールからcellを扱う場合は、現在のシートがどこだか指定する必要があります。 後半部もWorksheets.Addの後に書き込んでるから指定無しで動いてますが、途中で他のsheetの作業をしたりすると思わぬ不具合がおこったりしますよ。

ashishi
質問者

補足

回答ありがとうございます。 LookIn = Range("b1").Valueの前にSheets("sheet1").Selectを入れてみたんですが、やっぱり実行時エラーになってしまいます。 同じ課題をやっている友達は一発で実行できたんですが、僕のパソコンでは、友達と同じやり方でやっているのにもかかわらずできません。 補足で、エラーでいつも黄色く表示される場所はCells(i + 1, 2).Value = FileDateTime(.FoundFiles(i))です。 excelではsheet1に、b1にc:\ b2に*.txt b3に入力規則の設定で、入力値の種類リスト、元の値TRUE,FALSE を設定して、ボタン表示のTRUEを選んで実行してます。 なにかわかりましたらお願いします。

関連するQ&A

  • 他のブックでマクロを実行するには?

    以下のマクロを実行すると同一ブック内の他のシートに入力 されますが、これを他のブックのシートに入力されるように するには、具体的にどのようにすればいいのでしょうか? ご教授ください。 ---------------------------------------------------------------- Sub 入力() Dim LastRow As Long With Worksheets("sheet2") LastRow = Worksheets("sheet2").Range("B" & Rows.Count).End(xlUp).Row + 1 .Range("B" & LastRow).Value = Worksheets("sheet1").Range("B1").Value .Range("C" & LastRow).Value = Worksheets("sheet1").Range("B3").Value .Range("D" & LastRow).Value = Worksheets("sheet1").Range("B5").Value .Range("E" & LastRow).Value = Worksheets("sheet1").Range("B7").Value .Range("F" & LastRow).Value = Worksheets("sheet1").Range("B9").Value .Range("G" & LastRow).Value = Worksheets("sheet1").Range("B11").Value End With End Sub

  • ブック内に特定名のシートがある場合

    はじめまして、こんにちは。 VBAを最近はじめたばかりの者です。質問が初歩的なもので申し訳ないのですが是非教えてください。 以下を使って、複数ブックの○○というシートから指定セルの内容を抜き出したいと思っています。 ところが、ブックによっては○○というシートが存在しない場合があり、その場合には「インデックスが有効でない」というエラーで動作が止まってしまいます。 ブック内に○○というシートがある場合にのみ動作させるようにするにはどのようにすれば良いのでしょうか。 よろしくお願いします。 Dim wb As Workbook, myRow As Long Dim e As Integer myRow = ThisWorkbook.Worksheets(1).Rows.Count With Application.FileSearch .NewSearch .LookIn = ThisWorkbook.Path .SearchSubFolders = True .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then For i = 1 To .FoundFiles.Count If .FoundFiles(i) <> ThisWorkbook.FullName Then Set wb = Workbooks.Open(.FoundFiles(i), UpdateLinks:=0) Application.ScreenUpdating = False ThisWorkbook.Worksheets(1).Range("A" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F6").Value ThisWorkbook.Worksheets(1).Range("B" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F7").Value ThisWorkbook.Worksheets(1).Range("C" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F8").Value ThisWorkbook.Worksheets(1).Range("D" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("Y6").Value wb.Close False End If Next i Else MsgBox "ファイルがありません。" End If End With End Sub

  • エラー Nextに対するForがありませんについて

    VBAに慣れていないのですが、下記のマクロを組んでみました。 実行すると、コンパイルエラー Nextに対するForがありませんと出てしまいました。 原因が良く解らないので解る方いらっしゃいましたら教えてください。 それと、もっと良い書き方などありましたらアドバイスを下さい。 よろしくお願いします。 Sub レポート作成2each() Dim ReportMaxRow As Long '上方向に最終行を検索し行番号を格納 Dim AddWsName As String 'シート名格納 Dim Ws As Worksheet 'オブジェクト格納 Dim i As Long '繰り返しのカウントを格納 Dim flag As Boolean '真偽 ReportMaxRow = Worksheets("レポート元").Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To ReportMaxRow If Cells(i, "N").Value <> "" Then If Cells(i, "O").Value <> "" Then AddWsName = Cells(i, "K").Value For Each Ws In Worksheets If Ws = AddWsName Then flag = True Next Ws   ←ここでエラーになります。 If flag = True Then Worksheets("レポート元").Cells(i, 1).EntireRow.Copy _ Destination:=Worksheets(AddWsName).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) Else Worksheets.Add ActiveWorksheet.Name = AddWsName Worksheets("レポート元").Cells(i, 1).EntireRow.Copy _ Destination:=Worksheets(AddWsName).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) End If MsgBox i + "行目の発注数の入力がませんでした。" & vbNewLine & "処理を中断します, _ vbOKOnly + vbExclamation, "お知らせ" End If Else MsgBox i + "行目の発注数の入力がませんでした。" & vbNewLine & "処理を中断します", _ vbOKOnly + vbExclamation, "お知らせ" End If Next i End Sub

  • 実行時エラー'1004'で困っています。

    少し前にも同じコードの他の点についてアドバイスをいただいたのですが、新たな問題点が生じたので改めて質問させてほしいです。 具体的な問題点が分からなかったのでコードをそのまま載せました。 シート1に値を入力すると、繁殖牛データ。データ。という2個のシートから検索し、リンクをつけたいです。 繁殖牛データシートに入っている値を入力した時は ActiveSheet.Hyperlinks.Add anchor:=Target, Address:="", SubAddress:="'繁殖牛データ'!" & Range(Cells(kennsaku, 3)) データシートに入っている値を入力した時は ActiveSheet.Hyperlinks.Add anchor:=Target, Address:="", SubAddress:="'" & データ & "'!" & Range(Cells(kennsaku, 1)) で「'Range'メソッドは失敗しました:'_Worksheet'オブジェクト」とでます。 試験的にどちらのシートにも入っていない値を入力すると、思惑通りに"見つからないのでリンクは貼りません"と帰ってきます。 Private Sub Worksheet_Change(ByVal Target As Range) Dim kennsaku, y, z If Target.Count > 1 Then Exit Sub 'セルを二つ以上選択した場合 If Target.Value = "" Then Exit Sub 'データが空の場合 If Application.CountIf(Range("A1:Z80"), Target.Value) > 1 Then MsgBox Target.Value & "は既に入力されています", vbOKOnly + vbExclamation Target.Clear Exit Sub End If Set y = Worksheets("繁殖牛データ").Range("$C$1:$C$1003") Set z = Worksheets("データ").Range("$A$1:$A$65536") kennsaku = Application.Match(Target.Value, y, 0) If IsNumeric(kennsaku) Then ActiveSheet.Hyperlinks.Add anchor:=Target, Address:="", SubAddress:="'繁殖牛データ'!" & Range(Cells(kennsaku, 3)) Else kennsaku = Application.Match(Target.Value, z, 0) If IsError(kennsaku) Then MsgBox "見つからないのでリンクは貼りません", vbOKOnly + vbExclamation Exit Sub Else ActiveSheet.Hyperlinks.Add anchor:=Target, Address:="", SubAddress:="'" & データ & "'!" & Range(Cells(kennsaku, 1)) End If End If Range("A1:Z80").Font.Underline = False End Sub

  • Next,End Withのエラー

    Sub 入力() If Sheets("入力").Range("D3").Value = "" Then MsgBox "客先名を入力して下さい" Else Dim K最終行 As Long Dim T最終行 As Long Dim i As Integer With Sheets("入力") For i = 3 To 12 If .Cells(i, "H").Value <> "" Then U最終行 = Sheets("注文書").Range("G65536").End(xlUp).Row + 1 If U最終行 = 461 Then MsgBox "注文書がいっぱいです" Exit Sub Else End If E最終行 = Sheets("営業確認").Range("G65536").End(xlUp).Row + 1 Sheets("営業確認").Range("k" & E最終行).Value = .Cells(i, "b").Value Sheets("営業確認").Range("b" & E最終行).Value = .Cells(i, "c").Value Sheets("営業確認").Range("c" & E最終行).Value = .Cells(i, "d").Value Sheets("営業確認").Range("d" & E最終行).Value = .Cells(i, "e").Value Sheets("営業確認").Range("g" & E最終行).Value = .Cells(i, "h").Value Sheets("営業確認").Range("f" & E最終行).Value = .Cells(i, "i").Value Sheets("営業確認").Range("i" & E最終行).Value = .Cells(i, "m").Value Sheets("営業確認").Range("h" & E最終行).Value = .Cells(i, "p").Value Else End If Select Case .Cells(i, "o").Value Case "北" K最終行 = Sheets("北").Range("h65536").End(xlUp).Row + 1 Sheets("北").Range("B" & K最終行).Value = .Cells(3, "C").Value Sheets("北").Range("c" & K最終行).Value = .Cells(3, "b").Value Case "中" T最終行 = Sheets("中").Range("H65536").End(xlUp).Row + 1 Sheets("中").Range("b" & T最終行).Value = .Cells(3, "c").Value Sheets("中").Range("c" & T最終行).Value = .Cells(3, "b").Value End Select Exit Sub Dim Dummy As Worksheet Dim SheetName As String Dim OTA As Long Dim GEN As Long Dim SheetName2 As String With Sheets("入力") '3行目~22行目まで For j = 3 To 22 SheetName = Sheets("入力").Range("D3").Value On Error Resume Next Set Dummy = Sheets(SheetName) SheetName2 = .Cells(i, 14).Value 'もしシートがあれば・・・ If Err.Number = 0 Then 'SheetName2は入力シートのN行 SheetName2 = .Cells(i, 14).Value OTA = Sheets(SheetName2).Range("B65536").End(xlUp).Row + 1 Sheets(SheetName2).Range("A7").Value = .Cells(3, "D").Value Sheets(SheetName2).Range("C3").Value = .Cells(3, "C").Value Sheets(SheetName2).Range("B" & OTA).Value = .Cells(i, "H").Value Sheets(SheetName2).Range("I" & OTA).Value = .Cells(i, "I").Value Sheets(SheetName2).Range("F" & OTA).Value = .Cells(i, "K").Value Sheets(SheetName2).Range("H" & OTA).Value = .Cells(i, "L").Value Sheets(SheetName2).Range("J" & OTA).Value = .Cells(i, "M").Value 'シートが無ければ・・・ Else GEN = Sheets("原紙").Range("B65536").End(xlUp).Row + 1 Sheets("原紙").Range("A7").Value = .Cells(3, "D").Value Sheets("原紙").Range("C3").Value = .Cells(3, "C").Value Sheets("原紙").Range("B" & GEN).Value = .Cells(i, "H").Value Sheets("原紙").Range("I" & GEN).Value = .Cells(i, "I").Value Sheets("原紙").Range("F" & GEN).Value = .Cells(i, "K").Value Sheets("原紙").Range("H" & GEN).Value = .Cells(i, "L").Value Sheets("原紙").Range("J" & GEN).Value = .Cells(i, "M").Value '原紙をコピーする Sheets("原紙").Copy BEFORE:=Sheets(1) 'シートの名前を市場コードにする Sheets(1).Name = SheetName Next End With Exit Sub On Error GoTo 0 Sheets("原紙").Select Range("C3:E3,A7,B16:B35,F16:F35,H16:J35").Select Range("H35").Activate Selection.ClearContents Sheets("入力").Select Sheets("入力").Range("D3,G3:J12,L3:M12").Value = "" Sheets("入力").Range("D3").Select Range("B3").Formula = "=IF(D3="""","""",VLOOKUP(D3,'\\Seika-sv01\支店共有\マーケティング用\[担当者リスト.xls]リスト形式'!$B:$D,3,FALSE))" MsgBox "入力が完了しました" End If End Sub 上記のようにマクロを組みましたがエラーが出てしまいます。

  • インデックスが有効範囲に出ないと出る

    下記のようなVBAを書きました。しかしインデックスが有効範囲にないとメッセージがでるのですが、どこがまちがっているでしょうか?? Sub macro1() Dim i As Long Dim r As Long Worksheets("フェアリスト ").Select Worksheets("csv").Range("A:C").ClearContents For i = 2 To 50 Step 5 If Worksheets("フェアリスト").Cells(11, i + 1) <> "" Then r = Worksheets("フェアリスト").Cells(65536, i + 1).End(xlUp).Row Worksheets("フェアリスト").Range(Cells(11, i), Cells(r, i + 3)).Copy _ Destination:=Worksheets("csv").Range("B65536").End(xlUp).Offset(1) Worksheets("csv").Range("A65536").End(xlUp).Offset(1).Resize(r - 3, 1).Value = Worksheets("フェアリスト").Cells(8, i).Value End If Next i Worksheets("csv").Range("A1:C1").Delete shift:=xlShiftUp End Sub

  • Excelでwatabeさんに複数のセルを参照

    Excel2007でwatabe007さんに以前に作って頂いたこのようなソースがあります。 Sub Test4() Dim LastO As Long, LastG As Long Dim i As Long, str As String Range("D3", Cells(Rows.Count, "F").End(xlUp)).ClearContents LastO = Cells(Rows.Count, "O").End(xlUp).Row Range("A3:C3").Value = Cells(LastO, "O").Resize(, 3).Value str = Range("A3").Value & Range("B3").Value & Range("C3").Value For i = 3 To LastO   If str = Cells(i, "O").Value & Cells(i, "P").Value & Cells(i, "Q").Value Then     LastG = Cells(Rows.Count, "D").End(xlUp).Row + 1     If LastG < 3 Then LastG = 3     Cells(LastG, "D").Resize(, 3).Value = Cells(i + 1, "O").Resize(, 3).Value   End If Next End Sub これにいつも格子をつけて文字がセンターになるようにしたいですがどうすればよろしいですか?解答よろしくお願いいたします。

  • set文でエラーがでます

    以下のコードで  実行エラー''9'「インデックスが有効範囲にありません。」が出る原因と対処方法を教えてください。 Set ws = Worksheets(FileName2) FilewName2はローカルウインドウでは問題なく表示されています。 Sub 括弧及び括弧内文字削除() ' 'ダイアログでターゲットファイル(txt)を選択(読み込み) --------------- Dim FileName As Variant Dim FileName2 As String Dim FilePath As String Dim fso As New FileSystemObject FileName = Application.GetOpenFilename(FileFilter:="Txtファイル,*.txt) If FileName = False Then Exit Sub End If 'ターゲットファイルの拡張子無しのファイル名を取得 FileName2 = fso.GetBaseName(FileName) 'ターゲットファイルのパス取得 FilePath = Replace(FileName, Dir(FileName), "") Workbooks.Open FileName '括弧内文字列削除(括弧も含む)-------------------------------- Dim RegExp As Object Dim Cell As Range Dim tr As Long 'DATAを処理する行数 tr = Cells(Rows.Count, "A").End(xlUp).Row Set RegExp = CreateObject("VBScript.RegExp") RegExp.Global = True RegExp.Pattern = "[((].*[))]" ' Application.ScreenUpdating = False Dim buf Dim i As Long With Range("A1", Cells(Rows.Count, "A").End(xlUp)) buf = .Value For i = 1 To UBound(buf) buf(i, 1) = RegExp.Replace(buf(i, 1), "") Next .Value = buf End With ' Range(Cells(1, 1), Cells(tr, 1)).Select ' For Each Cell In Selection ' Cell = RegExp.Replace(Cell, "") ' Next '新規に修正ファイルをテキストファイルに書き出す ------------- Dim ws As Worksheet Set ws = Worksheets(FileName2) Dim datFile As String datFile = FilePath & FileName2 & "_mod.srt" Open datFile For Output As #1 For i = 1 To tr Print #1, ws.Cells(i, "A").Value Next Close #1 Application.ScreenUpdating = True MsgBox datFile & "に書き出しました" & vbCrLf & _ "処理が終了したのでEXCELを閉じて終了です。" '// Excelを終了する Application.Quit ActiveWorkbook.Close SaveChanges:=False ThisWorkbook.Close SaveChanges:=False End Sub

  • 指定したセルに1がない時、For を抜けたいのですが・・・

    Office XP Personal 2002 Excel 2002 指定した範囲セルに1がない時、下記の1つの For だけ を抜けたいのですが・・・ どのように変更すればよろしいでしょうか? よろしくお願い致します。 Sub test() Dim i As Integer Dim n As Range For i = 1 To Worksheets.Count - 1  Worksheets(i).Activate  For Each n In .Range("E6", .Range("E6").End(xlDown))   If Not n.Cells.Value = 1 Then   End If   Next n    MsgBox "「1」 がありません。", 48   Exit For  'For Each n In .Range("E6", .Range("E6").End(xlDown))   '続く   '・    '・ End Sub

  • 実行時エラー1004がでてしまう(VBA)

    実行時エラー1004「RangeクラスのAutoFilterメソッドが失敗しました」が出てしまいます。 (1)とあるシートのL列に"判定"を作り、そこに、D列の名称の中に、特、SO、FRが入っていないものには〇をL列に入力し、〇が付くものを抽出するというものを作ったのですがエラーが出てしまいます。(この内容は@の範囲になります)解決策を教えていただけないでしょうか? (2)またこのVBAを行った際に、本ファイルの処理リストのデータと評価リストのデータが消えてしまいます。(データがうまく表示されていない状態で行間をダブルクリックすれば全て出てくる)解決策を教えていただけないでしょうか? ちなみに自分はVBA初心者です。 Sub 抽出() Dim フォルダ, ファイル名, 基本ファイル名 Dim i, j As String i = ActiveWorkbook.Name j = ActiveSheet.Name Application.DisplayAlerts = False '警告ダイアログボックスを表示しない 基本ファイル名 = Sheets("データリスト").Range("B8").Value '基本ファイル名(欲しいデータがあるBook)を定義 Workbooks.Open 基本ファイル名 '基本ファイル名(欲しいデータがあるBook)を開く Worksheets(1).Range("A1:O400").Copy '基本ファイル名内にある履歴データシートの内容をコピー Workbooks(i).Worksheets("処理リスト").Range("A1:O400").PasteSpecial '基本ファイル名のコピーを本ファイルの処理リストに貼り付ける Workbooks(基本ファイル名).Close SaveChanges:=False '基本ファイル名を閉じる Sheets(j).Select With Worksheets("処理リスト") .Range("A1").AutoFilter _ Field:=10, _ Criteria1:="003", _ Operator:=xlOr, _ Criteria2:="004" End With '本ファイルの処理リストのA列からの10列目の"003"もしくは"004" を抽出 'Dim k As Long …@ Range("L1") = "判定" For k = 2 To Cells(Rows.Count, 1).End(xlUp).Row With Cells(k, 4).Interior If .Cells(k, 4) <> "" * 特 * "" And .Cells(k, 4) <> "" * SO * "" And .Cells(k, 4) <> "" * FR * "" Then Cells(k, 12) = "〇" End If End With Next k Range("A1").AutoFilter 12, "〇" →ここでエラーが出る …@ Dim データ範囲 As Range Dim 抽出列 As Variant Dim l As Long Set データ範囲 = Worksheets("処理リスト").Range("A1").CurrentRegion 抽出列 = Array(3, 4, 5, 10) For l = 0 To UBound(抽出列) データ範囲.Columns(抽出列(l)).Copy Sheets("評価リスト").Range("D7").Offset(0, l) Next '本ファイルの処理リストの3,4,5,10列を本ファイルの評価リストのD7に貼り付け Application.DisplayAlerts = True '警告ダイアログボックスを表示するに戻す MsgBox ("履歴データを取り込みました") End Sub

専門家に質問してみよう