Excel VBAで下記の質問者様の解答のコードを利用させて頂こうとしているのですが、うまくいきません。というかどこをいじればいいのかわからない状態です。
Excel VBAで下記の質問者様の解答のコードを利用させて頂こうとしているのですが、うまくいきません。というかどこをいじればいいのかわからない状態です。 やりたいことはファイル検索を完全一致ではなく部分一致にしたいです。 Dir関数でワイルドーカードを使用するのは分かったのですが、どこを変更すればいいのか・・・ それっぽいところを変更してみたのですがうまくいきません。 ご教示お願い致します。 https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q10177475930?__ysp=VkJBIOWGjeW4sOOAgOODleOCoeOCpOODq%2BOCs%2BODlOODvA%3D%3D
Visual Basic | Excel・173閲覧・25
ベストアンサー
検索ファイル名はA列に添付画像のように入れて下さい。 Public tbl As Variant Public spath As String Public cnt As Long Sub test() Dim fpath As String Dim r As Long r = Cells(Rows.Count, 1).End(xlUp).row If r < 2 Then MsgBox "検索ファイル名が入力されていません" Exit Sub End If With Application.FileDialog(msoFileDialogFolderPicker) .Title = "検索するフォルダを選択してください" If .Show = False Then Exit Sub fpath = .SelectedItems(1) & "\" End With With Application.FileDialog(msoFileDialogFolderPicker) .Title = "保存するフォルダを選択してください" If .Show = False Then Exit Sub spath = .SelectedItems(1) & "\" End With If fpath = spath Then MsgBox "検索フォルダと保存フォルダが同じです" Exit Sub End If Application.ScreenUpdating = False Application.DisplayAlerts = False tbl = Range("A1:A" & r) Call proc(fpath) Application.DisplayAlerts = True Application.ScreenUpdating = True MsgBox cnt & "件のファイルをコピーしました" End Sub Sub proc(fpath As Variant) Dim FSO As Object Dim subfol As Variant Dim fname As String Dim i As Long fname = Dir(fpath & "\" & "*.*", vbNormal) Do Until fname = "" For i = 2 To UBound(tbl) If InStr(fname, tbl(i, 1)) > 0 Then FileCopy fpath & "\" & fname, spath & "\" & fname cnt = cnt + 1 Exit For End If Next i fname = Dir() Loop Set FSO = CreateObject("Scripting.FileSystemObject") For Each subfol In FSO.GetFolder(fpath).SubFolders Call proc(subfol) Next subfol Set FSO = Nothing End Sub
質問者からのお礼コメント
理想通りの動きでした。 ありがとうございました。
お礼日時：1/12 18:50
