[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBA ファイル名が一部一致したら、一致した内容のフォルダへ移動』（MIKI）
こんばんは、お世話になります。
30種類ほど、出力されたPDFを同じグループ先のフォルダへ移動しているのですが、
恥ずかしながら毎度、手動でしていると、間違えてしまします｡°(っ°´o`°ｃ)°｡
なんとか自動で使用で使用と思っていますが、思ったように作動せず、
拾ってつなぎ合わせましたが、よくわからなく、どなたか教えていただけますでしょうか？
・「Aフォルダ」 → 「出力先」に、依頼と記載されたファイルがあります。
リンゴ依頼W2個1005.pdf
みかん依頼1005.pdf
ぶどう依頼今回のみ1004.pdf
もも依頼 10月のみ1003.pdf
パイナップルフルーツ依頼12.pdf
期間限定パイナップルフルーツ依頼50.pdf
・「Bフォルダ」→各項目名の中に移動したいです。
リンゴ（ファイルフォルダー）
みかん
ぶどう
もも
パイナップルフルーツ
期間限定パイナップルフルーツ
例）「リンゴ」フォルダ内に「1005リンゴ依頼.pdf」が移動されている
※ファイル名は日付が入っているので重複する可能性はないです。
Sub 一括移動()
Dim folder1 As String
Dim folder2 As String
Dim files As New Collection
Dim file As Variant
Dim folder As String
Dim f As String
Dim dr As String
folder1 = "C:\folderA\出力先\" '移動するExcelファイルのフォルダ(最後が\)
folder2 = "C:\folderB\依頼\" '保存先のExcelフォルダのフォルダ(最後が\)
'まずExcelファイルを取得
file = Dir(folder1 & "*.pdf") '最初のpdfファイル
Do While file <> "" 'ファイルがある間
files.Add file '記憶
file = Dir
Loop
'振り分け
For Each file In files '覚えているファイルを順に
f = file 'ファイル名
If InStr(f, "依頼") <> 0 Then 'ファイル名の中に"依頼"があれば
folder = Dir(folder2 & "*" & Mid(f, InStr(f, "依頼")) - 1, vbDirectory) '
If folder <> "" Then Name folder1 & file As folder2 & "\" & folder 'フォルダがあれば移動
End If
Next
Set files = Nothing '後始末
End Sub
＜ 使用 Excel：unknown、使用 OS：Windows10 ＞
（マナ） 2020/10/05(月) 19:01
（マナ） 2020/10/05(月) 19:04
早々のご回答ありがとうございます！
すみません、ないです！「パイナップルフルーツ」は同じフォルダ名は重複しないので、なしにしてください。
ややこしいことをいってしまいすみません！！ฅ(๑*д*๑)ฅ
下記のようになりますm(__)m
（例）
リンゴ（ファイルフォルダー）
みかん
ぶどう
もも
パイナップルフルーツ
バナナ
（MIKI） 2020/10/05(月) 19:05
これは、リンゴ が りんご になっていたり、半角カタカナになっていたりとかはしないってことですか？ あとはグレープフルーツとグレープのように、品名の中に別の品名が含まれている場合ってありますか？ （稲葉） 2020/10/05(月) 19:05
ありがとうございます。
＞＞各ファイル名は、必ず移動先のフォルダ名で始まりますか。
はいฅ(º ﾛ º ฅ)
ご認識の通り、ファイル名は、必ず移動先のフォルダ名ではじまります。
フォルダ名は”依頼”の文字より前の文字で完全一致になります。
よろしくお願いしますm(__)m
稲葉様
コメントありがとうございます。
＞＞これは、リンゴ が りんご になっていたり、半角カタカナになっていたりとかはしないってことですか？
あぁ！！それは私のミスです。。。。ｶﾀ:(ˊ◦ω◦ˋ):ｶﾀ
＞＞あとはグレープフルーツとグレープのように、品名の中に別の品名が含まれている場合ってありますか？
ないです！ ^^) _旦~~
（MIKI） 2020/10/05(月) 19:10
説明不足しており申し訳ありません！
文字は完全一致ですので、半角になっていたりは、ありません。
リンゴ ＝ リンゴ 〇
リンゴ ≠ りんご ×
リンゴ ≠ ﾘﾝｺﾞ ×
（MIKI） 2020/10/05(月) 19:13
なぜ、わざわざCollectionを使うのですか？
（マナ） 2020/10/05(月) 19:15
コメントありがとうございます。
すみません。マクロのCollection意味がわかってないです。。。(｡>д人)
素人で申し訳ないです。。。
（MIKI） 2020/10/05(月) 19:22
の代わりに
１）ファイル名からＭ移動先フォルダ名取得
２）ファイル移動
とすれば、よいのでは？
（マナ） 2020/10/05(月) 19:27
＞'ファイル名の中に"依頼"があれば
これは、
＞Dir(folder1 & "*.pdf")
↓
Dir(folder1 & "*依頼*.pdf")
で、よいと思います。
（マナ） 2020/10/05(月) 19:33
色々不安残りますが、とりあえずテスト済みです。 FileSystemObjectのほうが、最終的にわかりやすいかも知れません。
Sub test()
Const FolOut As String = "C:\folderA\出力先\" '移動するExcelファイルのフォルダ(最後が\)
Const FolIn As String = "C:\folderB\依頼\" '保存先のExcelフォルダのフォルダ(最後が\)
Dim sf As Variant
Dim FindName As String
Dim FileName As String
Dim errMsg As String
Dim ansMsg As String
Dim x As Variant
'//サブフォルダ一覧を探して、サブフォルダ名でループする
For Each sf In Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:D/B " & FolIn).StdOut().ReadAll(), vbNewLine)
If sf = "" Then Exit For
FindName = FolOut & "*" & sf & "依頼*.pdf"
ansMsg = ansMsg & sf & vbNewLine
'
'//サブフォルダ名を含むpdfファイルを検索し、ループする
For Each x In Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /B " & FindName).StdOut().ReadAll(), vbNewLine)
If x = "" Then Exit For
FileName = FolIn & sf & "\" & x
'
'念のため、重複チェック
If Dir(FileName) <> "" Then
errMsg = errMsg & x & vbNewLine
MsgBox FileName & "は既に存在しています"
Else
ansMsg = ansMsg & " " & x & vbNewLine
Name FolOut & x As FileName '移動処理
End If
Next x
Next sf
MsgBox "完了しました" & vbNewLine & ansMsg & vbNewLine & IIf(errMsg <> "", "重複：" & errMsg, "")
End Sub
余計なテスト行入ってたので、修正しました。19:57 （稲葉） 2020/10/05(月) 19:55
すでに回答が出そろっているようですが、面白そうなので参考出品です。 せっかくEXCELを使っているので処理結果をシートに出してみました。
Sub ファイル移動()
Const 入力先 As String = "C:\folderA\出力先"
Const 出力先 As String = "C:\folderB\依頼\" '// 出力は最後に\
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim ログシート As Worksheet
Set ログシート = Workbooks.Add().Worksheets(1)
Dim ログ出力行
ログ出力行 = 1
Dim 出力フォルダ
Dim 出力パス
Dim ファイル
For Each ファイル In fso.GetFolder(入力先).Files
If InStr(ファイル.Name, "依頼") > 0 And InStr(ファイル.Name, "pdf") > 0 Then
出力フォルダ = 出力先 & Split(ファイル.Name, "依頼")(0)
If fso.FolderExists(出力フォルダ) = True Then
出力パス = 出力フォルダ & "\" & ファイル.Name
ログシート.Cells(ログ出力行, "A").Value = "[" & ファイル.Name & "] を [ " & 出力パス & "]へ移動しました。"
fso.MoveFile ファイル.Path, 出力パス
Else
ログシート.Cells(ログ出力行, "A").Value = "[" & ファイル.Name & "] を 移動する[ " & 出力フォルダ & "]フォルダがありませんでした。"
ログシート.Cells(ログ出力行, "A").Interior.ColorIndex = 38
End If
ログ出力行 = ログ出力行 + 1
End If
Next
ログシート.Activate
MsgBox "処理が終了しました。"
End Sub
（QS） 2020/10/05(月) 23:43
要は
【こんなのを】 C:\folderA\出力先 ├リンゴ依頼W2個1005.pdf ├みかん依頼1005.pdf ├ぶどう依頼今回のみ1004.pdf ├もも依頼 10月のみ1003.pdf └パイナップルフルーツ依頼12.pdf
【こうしたい】 C:\folderB\依頼 ├リンゴ │ └リンゴ依頼W2個1005.pdf ├みかん │ └みかん依頼1005.pdf ├ぶどう │ └ぶどう依頼今回のみ1004.pdf ├もも │ └もも依頼 10月のみ1003.pdf ├パイナップルフルーツ │ └パイナップルフルーツ依頼12.pdf └バナナ
ということですよね。
この場合、ポイントはどのようにして保存先のフォルダ名を得るかというところだとおもいます。
この点において「フォルダ名は”依頼”の文字より前の文字で完全一致」とのことですから、そのままファイル名から”依頼”という文字列の前を取り出してみるというアプローチが使えます。
既にトライされたように、文字列操作で取り出すのも悪くないですが、今回のケースであれば"依頼"という文字列を【区切り文字】として考えるとsplit関数が使えそうです。興味があったらネット検索してみてください。
また、フォルダの中に目標のファイル以外がある可能性があり、依頼という文字列を含むpdfファイルだけを対象にしたいのであれば、マナさんが妙案を示されているのでそちらを採用されるとよいとおもいます。
そして上記２点と、元から使っていた
・Do～Loopステートメント
・Dir関数
・Nameステートメント
を組み合わせてみると、こんな感じになろうかとおもいます。
興味があればステップ実行して研究してみてください。
Sub 別案()
Const folder1 As String = "C:\folderA\出力先\"
Const folder2 As String = "C:\folderB\依頼\"
Dim ファイル名 As String
Stop 'ブレークポイントの代わり
ファイル名 = Dir(folder1 & "*依頼*.pdf")
Do Until ファイル名 = ""
Name folder1 & ファイル名 As folder2 & Split(ファイル名, "依頼")(0) & "\" & ファイル名
ファイル名 = Dir()
Loop
End Sub
■以下余談です■
余談(1)
私見ですが質問掲示板で顔文字を使うのは、あまりお勧めできません。
ぱっと見で、真面目に聞く気が無いと思われスルーされる確率があがってしまうように思います。
余談(2)
コードについて、こだわりがなければインデントを付けるようにしたほうがよいです。
特に、ループ処理や、条件分岐などが含まれるコードであれば、インデントを付けておいたほうが、ご自身のデバッグ作業がやりやすくなると思います。
（もこな２ ） 2020/10/06(火) 03:17
>顔文字を使うのは、あまりお勧めできません。 いろいろすみません
逆のアプローチ
Sub sample()
Const FolOut As String = "D:\folderA\出力先\"
Const FolIn As String = "D:\folderB\依頼\"
Dim FSO As Object, Sh As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Sh = CreateObject("WScript.Shell")
For Each aFolder In FSO.GetFolder(FolIn).SubFolders
Sh.Run "CMD /C MOVE " & FolOut & aFolder.Name & "依頼*.PDF " & aFolder.Path, 0
Next
End Sub
（´・ω・`） 2020/10/06(火) 06:37
わたしは顔文字好きですけどね パソコンだと変換できないやつは、読めませんが
（´・ω・`）さんのコードが完全に上位互換でした 勉強になりました。
（稲葉） 2020/10/06(火) 07:09
さて、（´・ω・`）さんが 2020/10/06(火) 06:37に提示されたコードについて私も研究してみました。
なるほどファイル名から移動先フォルダを得るのではなく、移動先フォルダ名から持ってくるファイルを選別するという逆発想もアリですね。思いつきませんでした。
ちなみにですが、「aFolder」の定義がないのですが、意図されたものなのでしょうか？
私の環境（Office365のExcelVBA）だと、変数宣言を強制するようにしているので普通にコンパイルエラーになっちゃいました。
質問者さんの環境でも同じことが起きるかもしれませんので、ちょこっとだけ改変させて頂いたものを提示しておきます。
Sub sample改造()
Const FolOut As String = "D:\folderA\出力先\"
Const FolIn As String = "D:\folderB\依頼\"
Dim aFolder As Object
For Each aFolder In CreateObject("Scripting.FileSystemObject").GetFolder(FolIn).SubFolders
CreateObject("WScript.Shell").Run "CMD /C MOVE " & FolOut & aFolder.Name & "依頼*.PDF " & aFolder.Path, 0
Next
End Sub
（もこな２） 2020/10/06(火) 15:31
＞なるほどファイル名から移動先フォルダを得るのではなく、移動先フォルダ名から持ってくるファイルを選別するという逆発想もアリですね。思いつきませんでした。 私もそう書いてるんだけど、ほんと癪に障るわ
（稲葉） 2020/10/06(火) 15:36
私のは皆さんのを見てからの後出しなので．．．． 工夫点は、コマンドラインのMOVEコマンドにワイルドカード指定しているところでしょうか。
>「aFolder」の定義がないのですが、 どうせVaiantだからいいかなと。サボりました。すみません。 ほんとはよくないです。 （´・ω・`） 2020/10/06(火) 15:55
こんばんは、コメントありがとうございます。
＞files.Add file '記憶
の代わりに
１）ファイル名からＭ移動先フォルダ名取得
２）ファイル移動
ご指導ありがとうございます。
勉強不足ですみません。取得するというのも見てみましたが、これはまた違いますでしょうか・・・
https://www.sejuku.net/blog/34439
何かを変えれば、動くと思っていましたが、マクロの記憶だよりですので、
上級者のことをしようと思ってしまいました。。。
考え方はわかったような気がします！ありがとうございますm(__)m
＞ Dir(folder1 & "*依頼*.pdf")
で、よいと思います。
ご指摘ありがとうございます！
これは、ほかにも代用できそうです！
（MIKI） 2020/10/06(火) 19:35
ご回答ありがとうございます！
うまく移動できました！！みたことない感じでなんだかすごいです。。。
すこしづつ分解して自分も理解深めますm(__)m
ありがとうございますm(__)mm(__)m
（MIKI） 2020/10/06(火) 19:37
ありがとうございます！！
いけました！なんだかエクセルが開くのがすごいです。
自分がテストをもう一度作ったのが、リンゴ、りんごと平仮名とカタカナを間違えてたのですが、
それもピンクになり、エクセルにその内容が記載されました！！！
今までは記憶と宣言しなくても動くからいっか、みたいな感じでいまだにわかるってことはないのですが
こういう繰り返しというか、フォルダ移動などのときに、わかってないとだめですね、、
ほかの方もすごいのですが、私にはすごすぎて皆さんの違いがよくわかってないです！すみません。
ですが本当に助かりますし、希望通りの自動になり感動です
（MIKI） 2020/10/06(火) 19:45
stopはずしました！いけました！！
私の最初拾ってきたのから、無理やりつめこみましたが、みなさん、まったく違い、すごいです。。
またこんなのをこうしたい！というの、わかりやすすぎです！！
私の説明不足でしたが、どうしたら、伝わりやすいかなぁ、。。と思っていましたが、これなら一目みてわかりますね。
質問するときの心得にします
split関数そんな区切りの関数があったのですね。
私は基本的にVBAの知識がなくエクセルの関数であれこれしてましたが、すごく深いですね！
区切りのときはエクセルの区切り位置みたいの使っていましたが、こういうことにも使えるのだなと思いました。
インデント！ご指摘ありがとうございます。
なんでみないつもガタガタなんだと思い、全部まっすぐにそろえていましたー。。
インデントの意味を入り、下記で理解しました、
https://thom.hateblo.jp/entry/2018/02/26/234247
IF、IFがあったときとかたしかにややこしいですもんね。。
勉強になりました！
（MIKI） 2020/10/06(火) 20:08
ありがとうございます！！ ^^) _旦~~
いけました！！なんだかすごくシンプルです！！したいことはすごいのに！
ほんとにみなさますごいですね。。
一方そのころ私は、1個みたら、意味わからなくて1個しらべてみたいな感じになっているので、まだまだ頑張ります！
ありがとうございます！！
（MIKI） 2020/10/06(火) 20:25
（もこな２）様
（´・ω・`）様
最後ご返信まとめますm(__)m
ほんとにありがとうございます！！みなさまの回答やご質問がすごすぎて追いついてないです。。
一方そのころ。。上位互換日本語なのに、意味調べてた私は、いったい！って感じです。
いろいろな方法があってみなさま本当にすごいのだなとあらためて思いました！
私もほかの方に教えられるようになりたいなと思いました(^^)/
ほんとに感謝です！お時間いただきありがとうございました ^^) _旦~~
（MIKI） 2020/10/06(火) 20:31
> 私もほかの方に教えられるようになりたいなと思いました(^^)/
ご活躍を楽しみにしています（╹◡╹）
（QS） 2020/10/06(火) 21:00
■（´・ω・`）さんへ
返答ありがとうございます。
■MIKIさんへ
＞stopはずしました！
ステップ実行して研究していただきたかったので意図的に入れたものです。
まだ、ステップ実行してなければトライしてみてください。（無理にとはいいませんが）
（もこな２ ） 2020/10/07(水) 08:08
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.