下記のVBAでExcel2003では出来たのですが、Excel2010ではエラーになります。
Excel2003と同じような動作をExcel2010で行いたいのですが、どこをどのように変えたら使用できるようになるでしょうか?
ネットで調べても初心者なもので全くわかりません。
Userform1に作成しているチェックボックスを選択すると、そのチェックボックスに対するドライブからファイルが検索される仕様になってます。
説明が下手で申し訳ありませんが、よろしくお願いします。
Private Sub CommandButton1_Click()
Set FSO = CreateObject("Scripting.FileSystemObject")
For x = 1 To 17
If Me.Controls("CheckBox" & x) = True Then Exit For 'チェックしてあるかを確認
If x = 18 Then Exit Sub
Next x
buf = InputBox("検索したいファイル名を入力してください" & vbCrLf & "ただし、複数キーワード検索はできません" & vbCrLf & "キーワード入力後、「OK」ボタンを選択", "キーワード入力")
If buf = "" Or buf = "False" Then Exit Sub
For x = 1 To 17
If Me.Controls("CheckBox" & x) = True Then
ドライブ = Chr(Asc("J") + x - 1)
Sheets(x + 1).Visible = True
Sheets(x + 1).Select
Cells(1, 1).Select
With Application.FileSearch
.NewSearch
.LookIn = ドライブ & ":\"
.Filename = buf
.SearchSubFolders = True
If .Execute() > 0 Then
MsgBox .FoundFiles.Count & " 個のファイルが見つかりました", vbOKOnly, "検索結果"
b = 1
Application.ScreenUpdating = False
For Each f In .FoundFiles
a = Range("C65536").End(xlUp).Row + 1
Cells(a, 2) = b
Cells(a, 3) = FSO.getfile(f).Name
Cells(a, 4) = FSO.getfile(f).DateLastModified
Cells(a, 5) = FSO.getfile(f).Path
b = b + 1
Next f
Else
MsgBox "見つかりませんでした"
Sheets(x + 1).Visible = False
End If
End With
For i = 5 To a Step 1
Cells(i, 3).Select
With ActiveSheet
.Hyperlinks.Add Anchor:=Selection, Address:=Cells(i, 5).Value
End With
Next i
If Range("E5") = "" Then
End
Else
Range(Cells(5, 5), Cells(a, 5)).Clear
End If
End If
Next x
Set FSO = Nothing
Cells(1, 1).Select
Unload UserForm1
End Sub
No.1
- 回答日時:
忙しい回答者の手を煩わすのだから、>エラーになります。
はどの行か参考までに書くべきです。ーー
また関係ないと思うコード部分は質問分からカットして質問文に載せるないこと。後半などはとりあえず質問と関係ないのでは。
質問者が色々試行して、エラーの起こっていそうな範囲を、狭めるのも大事なVBAの勉強でしょう。
ーー
本筋と関係ないかもしれないが
xが1から17まで繰り返してながら、そのループの中で
If x = 18 Then Exit Sub
とはなに?
こういうことも見抜けて以内。
ーー
>Excel2003では出来たのですが
は忘れてDebugに取り組むべきだ。
ーー
参考までにフォームに3つチェックボックスを設けて、テストしてみた
Private Sub CommandButton1_Click()
Set FSO = CreateObject("Scripting.FileSystemObject")
For x = 1 To 3
If Me.Controls("CheckBox" & x) = True Then GoTo p1 'チェックしてあるかを確認
Next x
MsgBox "チェックなし"
Exit Sub
p1:
MsgBox "チェックあり"
End Sub
上記は1つ見つかるとチェックを打ち切りだが、質問のコードは、この辺もおかしくないか。2つ以上チェックがあっても良いのか。
チェックが1つも入ってないときの事をどうしようとしているのか。
すいません。
ご指摘ありがとうございます。
If x = 18 Then Exit Subの部分ですが、xが18になったら抜けるようにしているのですが違いますか。
チェックは2つ以上あっても構いません。複数選択して検索させるためのものなので…
チェックが1つもないっていない場合は考えていませんでした。
No.2
- 回答日時:
ver2007以降、Application.FileSearchオブジェクトはサポートされていません。
http://support.microsoft.com/kb/920229/ja
代替手法でのコーディングが必要です。
以下、コマンドプロンプトのDIRコマンドを使う例。
Private Sub CommandButton1_Click()
Dim fso As Object
Dim drv As String
Dim buf As String
Dim tmp As String
Dim wrk As String
Dim r As Range
Dim x As Long
Dim n As Long
Dim a As Long
Dim i As Long
Dim cnt As Long
Dim v
For x = 1 To 17
If Me.Controls("CheckBox" & x) = True Then Exit For 'チェックしてあるかを確認
Next
If x = 18 Then Exit Sub
buf = InputBox("検索したいファイル名を入力してください" & vbCrLf & _
"ただし、複数キーワード検索はできません" & vbCrLf & _
"キーワード入力後、「OK」ボタンを選択", "キーワード入力")
If buf = "" Or buf = "False" Then Exit Sub
Set fso = CreateObject("Scripting.FileSystemObject")
wrk = Application.DefaultFilePath & "\temp" & CLng(Date) & ".txt"
For x = 1 To 17
If Me.Controls("CheckBox" & x) = True Then
drv = Chr(Asc("J") + x - 1)
tmp = "dir """ & drv & ":\*" & buf & "*"" /b/s"
CreateObject("WScript.Shell") _
.Run "%ComSpec% /c " & tmp & ">""" & wrk & """", 0, True
n = FreeFile
Open wrk For Input As #n
v = Split(StrConv(InputB(LOF(n), #n), vbUnicode), vbCrLf)
Close #n
cnt = UBound(v)
With Sheets(x + 1)
.Visible = True
If cnt > 0 Then
MsgBox "ドライブ " & drv & " に " & cnt & _
" 個のファイルが見つかりました", vbOKOnly, "検索結果"
Application.ScreenUpdating = False
a = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
For i = 0 To cnt - 1
Set r = .Cells(a + i, 2)
With fso.getfile(v(i))
r.Value = i + 1
r.Offset(, 1).Value = .Name
r.Offset(, 2).Value = .DateLastModified
r.Worksheet.Hyperlinks.Add Anchor:=r.Offset(, 1), _
Address:=.Path
End With
Set r = Nothing
Next
Else
MsgBox "ドライブ " & drv & " 見つかりませんでした"
.Visible = False
End If
End With
End If
Next
Kill wrk
Set fso = Nothing
Unload Me 'UserForm1
End Sub
ありがとうございます。
検索結果によってWith fso.getfile(v(i))やIf Me.Controls("CheckBox" & x) = True Thenの所でエラーが出ます。
ほとんどが前者のエラーが出ます。たまに後者のエラーも出るので統一性がわかりません。
検索結果数はきちんと出ますが、別シートに検索結果が表示されません。
もしよろしければ、こちらの方もお時間ありましたらお願いします。
No.3
- 回答日時:
エラーメッセージが何か、エラー時の変数v(i)やxの値は何か、
くらいは書かないと話がすすみません。
デバッグのやり方は知っておいてください。
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub0 …
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub0 …
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim fso As Object
Dim glg As Boolean
Dim drv As String
Dim buf As String
Dim tmp As String
Dim wrk As String
Dim r As Range
Dim x As Long
Dim n As Long
Dim a As Long
Dim i As Long
Dim cnt As Long
Dim v
buf = InputBox("検索したいファイル名を入力してください" & vbLf & _
"ただし、複数キーワード検索はできません" & vbLf & _
"キーワード入力後、「OK」ボタンを選択", "キーワード入力")
If buf = "" Or buf = "False" Then Exit Sub
Set fso = CreateObject("Scripting.FileSystemObject")
wrk = Application.DefaultFilePath & "\temp" & CLng(Date) & ".txt"
For x = 1 To 17
flg = False
On Error Resume Next
flg = Me.Controls("CheckBox" & x)
If Err.Number <> 0 Then
MsgBox Err.Number & "::" & Err.Description
End If
On Error GoTo 0
If flg Then
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(x + 1)
If Err.Number <> 0 Then
MsgBox Err.Number & "::" & Err.Description
End If
On Error GoTo 0
If Not ws Is Nothing Then
drv = Chr(Asc("I") + x - 1)
tmp = "dir /b/s """ & drv & ":\*" & buf & "*"""
CreateObject("WScript.Shell") _
.Run "%ComSpec% /c " & tmp & ">""" & wrk & """", 0, True
n = FreeFile
Open wrk For Input As #n
v = Split(StrConv(InputB(LOF(n), #n), vbUnicode), vbCrLf)
Close #n
cnt = UBound(v)
If cnt > 0 Then
ws.Visible = True
MsgBox "ドライブ " & drv & " に " & cnt & _
" 個のファイルが見つかりました。", vbOKOnly, "検索結果"
Application.ScreenUpdating = False
a = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row + 1
For i = 0 To cnt - 1
Set r = ws.Cells(a + i, 2)
r.Value = i + 1
If Len(v(i)) > 259 Then
r.Offset(, 1).Value = v(i)
MsgBox "フルパスが長すぎます。"
Else
With fso.getfile(v(i))
r.Offset(, 1).Value = .Name
r.Offset(, 2).Value = .DateLastModified
r.Worksheet.Hyperlinks.Add Anchor:=r.Offset(, 1), _
Address:=.Path
End With
End If
Set r = Nothing
Next
Application.ScreenUpdating = True
Else
MsgBox "ドライブ " & drv & " 見つかりませんでした。"
ws.Visible = False
End If
End If
End If
Next
On Error Resume Next
Kill wrk
On Error GoTo 0
Set fso = Nothing
Unload Me
End Sub
回答ありがとうございます。
申し訳ありません。初心者なので説明がきちんとできてませんでした。
検索結果数が少ないとちゃんと動作するようになりました。
ただ検索結果が多いと「実行時エラー'53':ファイルが見つかりません。」と出ます。
With fso.getfile(v(i))がエラーの対象です。
しかし検索結果数はきちんと出ています。
エラー時の変数の値ですが、よくわかりません。
検索結果が0か1つ出てる時もあるので1か2でしょうか。
よろしくお願いします。
No.5
- 回答日時:
リンク貼ったページの続きに『変数値の参照』があります。
読みましたか?http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub0 …
エラーで止まった時に v(i) にカーソルをあてると変数の内容がポップアップします。
もしくはVBE画面で[alt][v][s]。
[ローカルウィンドウ]を表示させて
変数の左にある+記号をクリックして変数の内容を確認できます。
または
:
Else
On Error Resume Next
With fso.getfile(v(i))
r.Offset(, 1).Value = .Name
r.Offset(, 2).Value = .DateLastModified
r.Worksheet.Hyperlinks.Add Anchor:=r.Offset(, 1), _
Address:=.Path
End With
If Err.Number <> 0 Then
r.Offset(, 1).Value = v(i)
End If
On Error GoTo 0
End If
:
エラー時はファイル名の代わりにフルパスをセルに入れるようにする、
などしてください。
返信遅れてすいません。
変数値ですが、v(i)=(ドライブ名):\(ファイルが格納されているフォルダ名)もしくは、i=0です。
フォルダは存在していて、その中に検索対象のファイルが格納されているのですが…
今回教えて頂いたものを少しいじってでやってみたのですが、検索結果が表示されません。
ファイル名もフルパスを入力するように変更しましたが、前回と同じWith fso.getfile(v(i))
の部分でエラーが出ます。
他のサイト見たり、VBAをいじったりしているのですが、難しくて結局出来ません…
No.6ベストアンサー
- 回答日時:
>変数値ですが、v(i)=(ドライブ名):\(ファイルが格納されているフォルダ名)もしくは、i=0です。
..そうでした..orz
フォルダを対象外にしなければいけませんね。
>tmp = "dir /b/s """ & drv & ":\*" & buf & "*"""
tmp = "dir /b/s/a:-d """ & drv & ":\*" & buf & "*"""
に変更です。
整理して、さらにfso使わないパターンで
Private Sub CommandButton1_Click()
Const MX = 17
Dim flg(1 To MX) As Boolean
Dim ws As Worksheet
Dim drv As String
Dim buf As String
Dim tmp As String
Dim wrk As String
Dim cnt As Long
Dim n As Long
Dim x As Long
Dim a As Long
Dim i As Long
Dim v
On Error GoTo errHndler
For x = 1 To MX
flg(x) = Me.Controls("CheckBox" & x).Value
Next
If Application.Or(flg) = False Then MsgBox "no check": Exit Sub
buf = InputBox("検索したいファイル名を入力してください" & vbLf & _
"ただし、複数キーワード検索はできません" & vbLf & _
"キーワード入力後、「OK」ボタンを選択", "キーワード入力")
If buf = "" Then Exit Sub
Set shl = CreateObject("WScript.Shell")
wrk = Application.DefaultFilePath & "\temp" & CLng(Date) & ".txt"
For x = 1 To MX
If flg(x) Then
Set ws = Worksheets(x + 1)
If Not ws Is Nothing Then
drv = Chr(Asc("J") + x - 1)
tmp = "dir /b/s/a:-d """ & drv & ":\*" & buf & "*"""
shl.Run "%ComSpec% /c " & tmp & ">""" & wrk & """", 0, True
n = FreeFile
Open wrk For Input As #n
v = Split(StrConv(InputB(LOF(n), #n), vbUnicode), vbCrLf)
Close #n
cnt = 0
cnt = UBound(v)
If cnt > 0 Then
ws.Visible = True
MsgBox "ドライブ " & drv & " に " & cnt & _
" 個のファイルが見つかりました。", vbOKOnly, "検索結果"
Application.ScreenUpdating = False
a = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row + 1
For i = 0 To cnt - 1
With ws.Cells(a + i, 2)
.Value = i + 1
.Offset(, 1).Value = Mid$(v(i), InStrRev(v(i), "\") + 1)
.Offset(, 2).Value = FileDateTime(v(i))
.Worksheet.Hyperlinks.Add Anchor:=.Offset(, 1), _
Address:=v(i)
End With
Next
Application.ScreenUpdating = True
Else
MsgBox "ドライブ " & drv & " 見つかりませんでした。"
ws.Visible = False
End If
Set ws = Nothing
End If
End If
Next
On Error Resume Next
Kill wrk
On Error GoTo 0
Set shl = Nothing
Unload Me
Exit Sub
errHndler:
Debug.Print Err.Number, Err.Description
Resume Next
End Sub
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・人生のプチ美学を教えてください!!
- ・10秒目をつむったら…
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・【大喜利】【投稿~9/18】 おとぎ話『桃太郎』の知られざるエピソード
- ・街中で見かけて「グッときた人」の思い出
- ・「一気に最後まで読んだ」本、教えて下さい!
- ・幼稚園時代「何組」でしたか?
- ・激凹みから立ち直る方法
- ・1つだけ過去を変えられるとしたら?
- ・【あるあるbot連動企画】あるあるbotに投稿したけど採用されなかったあるある募集
- ・【あるあるbot連動企画】フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
- ・映画のエンドロール観る派?観ない派?
- ・海外旅行から帰ってきたら、まず何を食べる?
- ・誕生日にもらった意外なもの
- ・天使と悪魔選手権
- ・ちょっと先の未来クイズ第2問
- ・【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
- ・推しミネラルウォーターはありますか?
- ・都道府県穴埋めゲーム
- ・この人頭いいなと思ったエピソード
- ・準・究極の選択
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
NAS上のファイルの使用中が解除...
-
EXCELのVBAでWORDが開いてある...
-
ACCESS VBAでのインポート
-
PowerShellを使って関連付けら...
-
EXCELのVBAでの保存方法
-
DisplayAlertsブロパティで ”実...
-
アクセスのクエリでコンパイル...
-
VBから参照できないCのDLLを使...
-
FTPの送信結果を検知したい
-
batファイルでレジストリキーの...
-
ASP.NET 2.0にてアプリが動作し...
-
fgets関数のEOFの扱い方について
-
freadでデータがない場合の読込...
-
アクセスでイベントのロジック...
-
ExcelVBAで既に開いてるwordを...
-
エクセル「これ以上新しいフォ...
-
すでにファイルが開かれている...
-
エラーを無視して次へ行きたい
-
ファイルの有無を確認した際の...
-
ファイルクローズ(fclose)でエ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Vba ファイル書き込み時に書き...
-
「パス名が無効です」の発生原因
-
Returnに対するGoSubがありません
-
PowerShellを使って関連付けら...
-
エクセル VBA dll 読み込...
-
batファイルでレジストリキーの...
-
gccを行ってもexeファイルが生...
-
アクセスのクエリでコンパイル...
-
VBから参照できないCのDLLを使...
-
access テキストボックスの値取得
-
VBでファイルが開かれているか...
-
EXCELのVBAでWORDが開いてある...
-
NAS上のファイルの使用中が解除...
-
VB6 Dir関数で52エラー発生
-
VBA ExecuteExcel4Macro 型が一...
-
エクセルマクロでエラーの原因...
-
fgets関数のEOFの扱い方について
-
【COBOL】read文でエラー
-
FTPの送信結果を検知したい
-
FORTRANの実行エラーについて
おすすめ情報