アプリ版：「スタンプのみでお礼する」機能のリリースについて

FileSearchがExcel2010でできない

解決済

  • 質問者：na-chi21
  • 質問日時：
  • 回答数：6件

下記の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 & "キーワード入力後、「ＯＫ」ボタンを選択", "キーワード入力")
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

通報する

この質問への回答は締め切られました。

質問の本文を隠す

A 回答 (6件)

No.6ベストアンサー

  • 回答者： end-u
  • 回答日時：

>変数値ですが、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 & _
　　　　　　　　　 "キーワード入力後、「ＯＫ」ボタンを選択", "キーワード入力")
　　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
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございます。
教えて頂いた通りにしたらきちんと検索し動作しました。
何度も回答していただきありがとうございました。

通報する
お礼日時：2011/05/17 23:27

No.5

  • 回答者： end-u
  • 回答日時：

リンク貼ったページの続きに『変数値の参照』があります。

読みましたか？
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
：
エラー時はファイル名の代わりにフルパスをセルに入れるようにする、
などしてください。
    • good
    • 0
    • 件
通報する
この回答へのお礼

返信遅れてすいません。
変数値ですが、v(i)=（ドライブ名）:\（ファイルが格納されているフォルダ名）もしくは、i=0です。
フォルダは存在していて、その中に検索対象のファイルが格納されているのですが…
今回教えて頂いたものを少しいじってでやってみたのですが、検索結果が表示されません。
ファイル名もフルパスを入力するように変更しましたが、前回と同じWith fso.getfile(v(i))
の部分でエラーが出ます。
他のサイト見たり、VBAをいじったりしているのですが、難しくて結局出来ません…

通報する
お礼日時：2011/05/14 11:57

No.4

  • 回答者： end-u
  • 回答日時：

コードアップミス。


一箇所修正してください。

>drv = Chr(Asc("I") + x - 1)
drv = Chr(Asc("J") + x - 1)
    • good
    • 0
    • 件
通報する

No.3

  • 回答者： end-u
  • 回答日時：

エラーメッセージが何か、エラー時の変数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 & _
　　　　　　　　　 "キーワード入力後、「ＯＫ」ボタンを選択", "キーワード入力")
　　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
    • good
    • 0
    • 件
通報する
この回答へのお礼

回答ありがとうございます。
申し訳ありません。初心者なので説明がきちんとできてませんでした。
検索結果数が少ないとちゃんと動作するようになりました。
ただ検索結果が多いと「実行時エラー'53':ファイルが見つかりません。」と出ます。
With fso.getfile(v(i))がエラーの対象です。
しかし検索結果数はきちんと出ています。
エラー時の変数の値ですが、よくわかりません。
検索結果が０か１つ出てる時もあるので１か２でしょうか。
よろしくお願いします。

通報する
お礼日時：2011/04/28 19:30

No.2

  • 回答者： end-u
  • 回答日時：

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 & _
　　　　　　　　 "キーワード入力後、「ＯＫ」ボタンを選択", "キーワード入力")
　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
    • good
    • 0
    • 件
通報する
この回答へのお礼

ありがとうございます。
検索結果によってWith fso.getfile(v(i))やIf Me.Controls("CheckBox" & x) = True Thenの所でエラーが出ます。
ほとんどが前者のエラーが出ます。たまに後者のエラーも出るので統一性がわかりません。
検索結果数はきちんと出ますが、別シートに検索結果が表示されません。
もしよろしければ、こちらの方もお時間ありましたらお願いします。

通報する
お礼日時：2011/04/27 11:27

No.1

  • 回答者： imogasi
  • 回答日時：

忙しい回答者の手を煩わすのだから、＞エラーになります。

　はどの行か参考までに書くべきです。
ーー
また関係ないと思うコード部分は質問分からカットして質問文に載せるないこと。後半などはとりあえず質問と関係ないのでは。
質問者が色々試行して、エラーの起こっていそうな範囲を、狭めるのも大事なＶＢＡの勉強でしょう。
ーー
本筋と関係ないかもしれないが
xが１から１７まで繰り返してながら、そのループの中で
If x = 18 Then Exit Sub
とはなに？
こういうことも見抜けて以内。
ーー
＞Excel2003では出来たのですが
は忘れてＤｅｂｕｇに取り組むべきだ。
ーー
参考までにフォームに３つチェックボックスを設けて、テストしてみた
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
上記は１つ見つかるとチェックを打ち切りだが、質問のコードは、この辺もおかしくないか。２つ以上チェックがあっても良いのか。
チェックが１つも入ってないときの事をどうしようとしているのか。
    • good
    • 0
    • 件
通報する
この回答へのお礼

すいません。
ご指摘ありがとうございます。
If x = 18 Then Exit Subの部分ですが、xが18になったら抜けるようにしているのですが違いますか。
チェックは２つ以上あっても構いません。複数選択して検索させるためのものなので…
チェックが１つもないっていない場合は考えていませんでした。

通報する
お礼日時：2011/04/27 11:44

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう！

Q質問する（無料）

関連するカテゴリからQ&Aを探す

ページトップページトップ

Q質問する（無料）

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

おすすめ情報