Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(指定なし : 指定なし)
ファイル一覧の抽出の中で、検索できる機能を付けたい。
投稿日時: 17/12/08 14:57:38
投稿者: いしやん

お疲れ様です。
あるフォルダの中のファイルを抽出する一覧を表示するものを作成しました。
追加機能として、Cells(3, 2)に入力した文字に、ヒット(該当)するものだけを
表示させたいのですが、分岐条件で、cells(3,2)とFILE.NAMEを比較して、(like?)
その場合のみ、値を入力するように考えておりますが、分岐の挿入位置と比較の条件がよくわかりません。
申し訳ございませんが、アドバイスお願いします。
 
Private Sub TextBox1_Change()
    Cells(3, 2) = TextBox1.Value
End Sub
 
 
コード
 
Dim cnt As Long
 
Sub MENU()
    UserForm1.Show vbModeless
End Sub
 
Sub KFOL() '検索フォルダの登録
 
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = True Then
                Cells(2, 2) = .SelectedItems(1)
            End If
        End With
End Sub
 
Sub Extraction() 'ファイル抽出メインプログラム
    cnt = 4
    Call dataclear
     
        If Cells(2, 2) = "" Then
               
              MsgBox "検索フォルダを登録してください。"
               
              Exit Sub ' 検索フォルダはない時、終了
               
        Else
     
            Call ExtractSUB(Cells(2, 2).Value)
   
        End If
          
        Dim i As Long
 
            i = WorksheetFunction.CountA(ActiveSheet.Range(Cells(5, 1), Cells(5, 1).End(xlDown)))
 
            MsgBox "ファイルは、" & i & "件です。", vbInformation '
           
         
End Sub
  
Sub ExtractSUB(PATH As String)
 
On Error GoTo myError
 
    Dim FOLDA As Object, FILE As Object, UPFOL As Object
     
    With CreateObject("Scripting.FileSystemObject")
        'ファイルの検索
        For Each FILE In .GetFolder(PATH).Files
         
                        
            cnt = cnt + 1
            Cells(cnt, 2).Value = FILE.Name
            Cells(cnt, 1).Value = PATH
             
             
                    If Cells(cnt, 2) = "" Then
                     
                    Else
                     
                        Cells(cnt, 1) = "↑"
                     
                    End If
                         
                With ActiveSheet.Hyperlinks
                .Add Anchor:=Cells(cnt, 2), Address:=FILE.PATH
                .Add Anchor:=Cells(cnt, 1), Address:=PATH
                 
                End With
         
         
        Next FILE
  
        'サブフォルダの検索
        For Each FOLDA In .GetFolder(PATH).SubFolders
            Call ExtractSUB(FOLDA.PATH) 'サブフォルダがあれば、サブフォルダのパスを引数にして再帰呼出
        Next FOLDA
         
    End With
    
myError:
 
    Exit Sub
     
 
    
End Sub
 
Sub dataclear()
 
  'データクリア
  Cells(5, 1).Select
   
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
   
   
  Selection.ClearContents
     
  Cells(1, 1).Select
 
 
End Sub
 
 

回答
投稿日時: 17/12/08 15:32:28
投稿者: WinArrow
投稿者のウェブサイトに移動

掲示のコードは、自作ですか?
 
それとも、他人のコードを拝借?
 

投稿日時: 17/12/08 15:51:23
投稿者: いしやん

様々なところから、拝借させて頂きまして、
 
自分で少し変更しました。根本的な作り方が間違っているかもしれませんが、
 
ここでは、自作のものしか、アップしてはダメなのでしょうか?
 
まだ、やり始めたところなので、、
無礼な振舞でしたら、すぐ削除します。

回答
投稿日時: 17/12/08 17:22:16
投稿者: WinArrow
投稿者のウェブサイトに移動

>ここでは、自作のものしか、アップしてはダメなのでしょうか?
 
そんなことありませんよ!
 
どの程度コードを理解しているかを知りたかったのです。
 
>様々なところから、拝借させて頂きまして、
これも、大いに結構です。
 
ただ、修正を加える時、元コード作成時の思想なり、コードの意味をキチンと理解した上でないと、
まっすぐなレールが、どことなく、曲がってしまってしまいます。(目に見えるとよいですが・・・)
 
> Cells(cnt, 2).Value = FILE.Name
↑のコードは理解していますか?
ここで、ファイル名がわかりますよね?
 
ですから、これより、前の段階で、判断する必要があるわけです。
 
 
 
 
判断するには、
IF FILE.Name Like "*●●*" Then
のようなコードで対応できます。
 
 
 

回答
投稿日時: 17/12/08 18:04:26
投稿者: もこな2

以前にあった質問の続きというか、回答をもとにご自身でブラッシュアップされたコードですよね
ご質問の回答については WinArrowさんが既に回答されていますので割愛します。(まぁうっかり下記コードに書いちゃいましたが・・・・)
 
そのほか余計なお世話かもしれませんがちょっとコメント等を追加しました

Sub KFOL() '検索フォルダの登録
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = True Then
                '「B2」セルに検索フォルダ(ルート)を出力
                Cells(2, 2) = .SelectedItems(1)
            End If
        End With
End Sub

Sub Extraction() 'ファイル抽出メインプログラム
    cnt = 4

’(注釈1)
'データクリア
    Range(Cells(5, 1), Cells(Cells(5, 1).End(xlDown).Row, "B")).ClearContents

'検索フォルダ未指定時の処理
    If Cells(2, 2) = "" Then
        MsgBox "検索フォルダを登録してください。"
        Exit Sub ' 検索フォルダはない時、終了
    End If '---------条件に合致するとき、「Exit Sub」なら、以降は実行されないことになる
                           'つまり、条件に合致しない場合は実行するってことだから
                           'Elesに書かなくても大丈夫(書いてダメではない)

'ExtractSUBの呼出(引数:検索フォルダ)
    Call ExtractSUB(Cells(2, 2).Value)

'見つかった件数の表示
        Dim i As Long
        i = WorksheetFunction.CountA(ActiveSheet.Range(Cells(5, 1), Cells(5, 1).End(xlDown)))
        MsgBox "ファイルは、" & i & "件です。", vbInformation '

End Sub

Sub ExtractSUB(PATH As String)

On Error GoTo myError

Dim FOLDA As Object, FILE As Object, UPFOL As Object

With CreateObject("Scripting.FileSystemObject")
    'ファイルの検索
    For Each FILE In .GetFolder(PATH).Files
        'If 〜〜〜が真なら処理
            cnt = cnt + 1
            Cells(cnt, 2).Value = FILE.Name
            Cells(cnt, 1).Value = PATH
'(注釈2)
            With ActiveSheet.Hyperlinks
                .Add Anchor:=Cells(cnt, 2), Address:=FILE.PATH
                .Add Anchor:=Cells(cnt, 1), Address:=PATH
            End With
        'End If を忘れずに
    Next FILE

    'サブフォルダの検索
    For Each FOLDA In .GetFolder(PATH).SubFolders
        Call ExtractSUB(FOLDA.PATH) 'サブフォルダがあれば、サブフォルダのパスを引数にして再帰呼出
    Next FOLDA
End With

Exit Sub '追加 (理由は後述)
myError:
    Stop ' 追加        せっかくエラートラップを作っているからブレークポイントとして活用
    'Exit Sub'        ただ、エラートラップするなら「Exit Sub」はもうちょい上

End Sub

(注釈1)
'# 1 Call dataclear'
'# 2 Cells(5, 1).Select
'# 3 Range(Selection, Selection.End(xlToRight)).Select
'# 4 Range(Selection, Selection.End(xlDown)).Select
'# 5 Selection.ClearContents
'# 6 Cells(1, 1).Select

dataclearを 呼び出しているところと、そのdataclearの内容ですが
とりあえず、いちいちselectしなくても大丈夫です。
また、設計上「A列」と「B列」以外に出力されないことがわかってるから列方向は検索しなくても大丈夫なので、このような書き方でメインプログラムに組み込んでしまっても良いかと思います。
 
(注釈2)
'#1 If Cells(cnt, 2) = "" Then
'#2 Else
'#3   Cells(cnt, 1) = "↑"
'#4 End If

の部分ですが「Cells(cnt, 2) = ""」じゃないとき を表現したければ、「Cells(cnt, 2) <> ""」や「Not Cells(cnt, 2) = ""」という表現も可能です。
ただ、「Files」の中身に、ファイル名がないものは存在しないはずだから、必ず#3は実行されてしまうような・・・そうすると、ちょっと前に「Cells(cnt, 1).Value = PATH」ってやってますけど、ここいらないですよね?(「Cells(cnt, 1).Value = "↑"」に置き換えても問題ないですよね)

回答
投稿日時: 17/12/09 10:19:48
投稿者: simple

余談ですが、質問者さんの提示されたコード、少し見にくくないですか?
不規則な空行が影響しているのでしょうか。
例えば、こんな風に書いた方が見やすくないですか?
内容は変えていません。
 
Dim cnt As Long

Sub MENU()
    UserForm1.Show vbModeless
End Sub

Sub KFOL()    '検索フォルダの登録
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            Cells(2, 2) = .SelectedItems(1)
        End If
    End With
End Sub

Sub Extraction()    'ファイル抽出メインプログラム
    cnt = 4
    Call dataclear

    If Cells(2, 2) = "" Then
        MsgBox "検索フォルダを登録してください。"
        Exit Sub
    Else
        Call ExtractSUB(Cells(2, 2).Value)
    End If

    Dim i As Long
    i = WorksheetFunction.CountA(ActiveSheet.Range(Cells(5, 1), Cells(5, 1).End(xlDown)))
    MsgBox "ファイルは、" & i & "件です。", vbInformation    '
End Sub

Sub ExtractSUB(PATH As String)
    Dim FOLDA As Object, FILE As Object, UPFOL As Object

    On Error GoTo myError
    With CreateObject("Scripting.FileSystemObject")
        'ファイルの検索
        For Each FILE In .GetFolder(PATH).Files
            cnt = cnt + 1
            Cells(cnt, 2).Value = FILE.Name
            Cells(cnt, 1).Value = PATH
            If Cells(cnt, 2) = "" Then
            Else
                Cells(cnt, 1) = "↑"
            End If

            With ActiveSheet.Hyperlinks
                .Add Anchor:=Cells(cnt, 2), Address:=FILE.PATH
                .Add Anchor:=Cells(cnt, 1), Address:=PATH
            End With
        Next FILE

        'サブフォルダの検索
        For Each FOLDA In .GetFolder(PATH).SubFolders
            'サブフォルダがあれば、サブフォルダのパスを引数にして再帰呼出
            Call ExtractSUB(FOLDA.PATH)   
        Next FOLDA
    End With
myError:
    Exit Sub
End Sub

Sub dataclear()
    'データクリア
    Cells(5, 1).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Cells(1, 1).Select
End Sub

回答
投稿日時: 17/12/09 11:35:41
投稿者: LMK

simple さんのおかげで読む気になれました。
さて、遠回りが嫌いな私としては、反復する部分を少しでも軽くしたいところです。
(質問の趣旨とは違いますが)
 
Dim cnt As Long

Sub Extraction()    'ファイル抽出メインプログラム
    cnt = 4
    Call ExtractSUB(CreateObject("Scripting.FileSystemObject").GetFolder(Cells(2, 2).Value))
    MsgBox "ファイルは、" & cnt - 4 & "件です。", vbInformation
End Sub

  
Sub ExtractSUB(argFld As Object)
    Dim pth As String, fl As Object, fld As Object
    pth = argFld.Path
    
    'ファイルの検索
    For Each fl In argFld.Files
        cnt = cnt + 1
        Cells(cnt, 1).Value = pth
        Cells(cnt, 2).Value = fl.Name
    Next fl
    
    'サブフォルダの検索
    For Each fld In argFld.SubFolders
        'サブフォルダがあれば、サブフォルダを引数にして再帰呼出
        Call ExtractSUB(fld)
    Next fld
End Sub

 
ところで、FSOで普通にファイルを取得すると、隠しファイル(システムファイル)が拾われませんか?

回答
投稿日時: 17/12/09 22:36:51
投稿者: LMK

いやはや今初めて今回の質問を拝見しました。
 
そういうことならDir関数の方が向いていますね。
サブフォルダを取得する部分はFSOでもいいでしょうけど(どちらかというと書きやすいので)

投稿日時: 17/12/11 09:34:01
投稿者: いしやん

皆様、助言ありがとうございます。
今回、ようやくやりたいと思っていたところまで、たどり着けました。
 
ただコードの詳細の意味や見やすい書き方、重複してしまっているところなど、
まだまだ、未熟でありますが、少しづつ頑張っていきます。
 
アドバイスありがとうございました。