Excel VBA ファイルコピー後フォルダ振り分けについて

Question

Excel2016を利用しています。複数ファイルをコピーしてフォルダ振り分けをしたいです。＜コピー元＞ C:\Users\81906\Desktop\マクロテスト\コピー元このフォルダ内に、100程度のWord又はPDFがあり、それぞれの先頭4文字は数字4桁、その後はスペースと任意文字色々です。例えば、「0001 ●●●●」「0001 ×××」「0002 ●●●」「0002 ×××」「0003 ●●●」「0004 ×××」＜コピー先＞ C:\Users\81906\Desktop\マクロテスト　（以下、「コピー先親フォルダ」という。テストのため便宜的にコピー元とコピー先のディレクトリが重なっているが、全然別です。）コピー先親フォルダの中に「0001 あいうえお」「0002 かきくけこ」「0003 さしすせそ」「0004 たちつてと」というフォルダ（以下それぞれを「コピー先フォルダ」といいます。各コピー先フォルダの先頭4文字は、コピー元ファイルの先頭4文字と一致しますが、対応するファイルがないフォルダ、例えば「1111 わいうえお」というフォルダもあります。）、各コピー先フォルダの下に「aaaa」という同一名のフォルダがあります。＜やりたいこと＞１、各コピー先フォルダの「aaaa」フォルダの下に、同一名の「bbbb」というフォルダを作成する２、コピー元のファイル名の先頭4文字と、各コピー先フォルダ名の先頭4文字が同一のコピー先フォルダの（１で作成された）サブフォルダbbbbにコピーする以下の記述を加工してできそうでしょうか。。 Sub test() 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:\Users\81906\Desktop\マクロテスト\コピー元\" folder2 = "C:\Users\81906\Desktop\マクロテスト\" 'まずExcelファイルを取得 file = Dir(folder1) '最初のファイル Do While file <> "" 'ファイルがある間 files.Add file '記憶 file = Dir Loop '振り分け For Each file In files '覚えているファイルを順に f = file 'ファイル名 If Left(f, 3) = "abc" Then 'ファイル名の中に"abc"があれば folder = Dir(folder2 & "*" & Left(f, 4), vbDirectory) 'ファイル名の左から4つ目までの文字列が、フォルダ名と同じフォルダを検索 If folder <> "" Then Name folder1 & file As folder2 & folder & "\" & file 'フォルダがあれば移動 End If Next Set files = Nothing '後始末 End Sub

Qchan1962 · Accepted Answer

ご質問や補足を読んでも理解にたどり着けず、気になっていましたので
勝手に下記のように整理してみましたが、、果たしてどうだか？
アドバイスとしても中々どのようにすれば良いか、、、
無責任に実行コードを書きました。

＞1. 管理番号［3］[4」のみ階層:「DDD」を作成したい(深い階層のみフォルダを作成したい)
これについては、作成の条件が解らないので、フルパスで指定すれば、作成できるかと思います。
例えば、
If　・・・ ' 作成する場合の条件を明確に検討する
    NewFol = "C:\Users\81906\Desktop\マクロテスト\・・・・"
    If Dir(NewFol, vbDirectory) = "" Then MkDir NewFol
End If
フォルダの作成する場合、しない場合明確にして、最下位フォルダ取得時に作成すれば良いですね。

＞2.　1で作成したフォルダに、(ファイル冒頭に管理番号が付いているので)ファイルをコピーして保存する。
コピー先フォルダは作成されているものとして

条件確認　（例を参考）
コピー元のファイルの場所　　（コピー元フォルダ内）
管理番号+AAA群の場所　　　1つ上の階層　コピー元フォルダと同じ階層　（マクロテストフォルダ内）
この階層で管理番号の一致するフォルダを探し、最下位階層のフォルダを探してファイルをコピーする。

管理番号+AAAの中に管理番号+BBBがあり、さらに管理番号+CCC内に管理番号+DDDがあるDDDは、管理番号+AAA内の最下位階層フォルダ
この最下位階層フォルダ内にファイルをコピーする。
各サブフォルダには、対象サブフォルダが1つだけある（複数あっても良いが、対象の管理番号+フォルダ名は1つ）
コピー条件は、管理番号（4桁）が一致している事、さらに、pdf,　docxファイルである事。

上記内容を確認して該当しない場合は、捨ててください。
フォルダーを探して処理する形ですので、管理番号が一致しなければ処理されません。

フォルダ選択はダイアログでファイル群のあるフォルダを選択してください。（ここ大事）

テスト環境を作るのは手間なので未検証ですが、フォルダパス、変数の確認は一応行っています。
気になってもやもやしてしまい、いきなり実行コードを作ってしまいましたが、内容をよく確認上検証をお願いします。

サブフォルダ検索で再帰処理を行っていますので、あらかじめMicrosoftScriptingRuntimeを参照してください。

コードをコピーして出来ましたとは行かないと思いますので、参考まで。。

Option Explicit
Dim TrgSubFolders() As Variant
Dim n As Long
Sub FileOperation_SubFolders()
　　Dim f As Object, objSubFolders As Object
　　Dim Folder_Path As String, objParentFolders As String, TrgFolder As String
　　Dim TrgFiles As Variant, i As Long: i = 0
　　'---------ダイアログでフォルダの指定
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　.InitialFileName = CreateObject("WScript.Shell").SpecialFolders("desktop")
　　　　If .Show = True Then
　　　　　　Folder_Path = .SelectedItems(1) & "\"
　　　　End If
　　End With
　　If Folder_Path = "" Then End
　　On Error Resume Next　　　　 '念のため
　　With CreateObject("Scripting.FileSystemObject")
　　　　'----------フォルダ内ファイル抽出
　　　　For Each f In .GetFolder(Folder_Path).Files
　　　　　　If LCase(.GetExtensionName(f)) = "docx" Or _
　　　　　　　　　　LCase(.GetExtensionName(f)) = "pdf" Then
　　　　　　　　ReDim Preserve TrgFiles(i)
　　　　　　　　TrgFiles(i) = f.Name
　　　　　　　　i = i + 1
　　　　　　End If
　　　　Next
　　　　If TrgFiles Is Nothing Then MsgBox ("対象ファイルがありません"): Exit Sub
　　　　'----------親フォルダを取得
　　　　objParentFolders = .GetParentFolderName(Folder_Path) & "\"
　　　　For i = 0 To UBound(TrgFiles)　　'ターゲットファイル配列
　　　　　　'----------親フォルダ内のフォルダを取得
　　　　　　For Each objSubFolders In .GetFolder(objParentFolders).SubFolders
　　　　　　　　If Left(TrgFiles(i), 4) = Left(objSubFolders.Name, 4) Then
　　　　　　　　　　n = 0　　'再帰処理
　　　　　　　　　　Call listSubFolders(objSubFolders, n, Left(objSubFolders.Name, 4))
　　　　　　　　　　If TrgSubFolders(n - 1) <> "" Then
　　　　　　　　　　　　TrgFolder = TrgSubFolders(n - 1)　　'最下位フォルダ
　　　　　　　　　　Else
　　　　　　　　　　　　TrgFolder = objSubFolders
　　　　　　　　　　End If
　　　　　　　　　　'　メイン処理
　　　　　　　　　　'　　　　　　　　.MoveFile Folder_Path & "\" & TrgFiles(i), TrgFolder
　　　　　　　　　　.CopyFile Folder_Path & "\" & TrgFiles(i), TrgFolder
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next objSubFolders
　　　　Next i
　　End With
End Sub
Private Sub listSubFolders(ByVal objSubFolders As Scripting.Folder, ByRef n As Long, FKey As String)
　　Dim fol As Scripting.Folder
　　On Error GoTo ErrCheck
　　For Each fol In objSubFolders.SubFolders
　　　　If Left(fol.Name, 4) = FKey Then
　　　　　　ReDim Preserve TrgSubFolders(n)
　　　　　　TrgSubFolders(n) = fol & "\"
　　　　　　n = n + 1
　　　　　　listSubFolders fol, n, FKey　'再帰処理
　　　　End If
　　Next
　　Set fol = Nothing
　　On Error GoTo 0
　　Exit Sub
ErrCheck:
　　MsgBox (Err.Number)
End Sub

Qchan1962 · Answer

すみません、メイン処理
　　　.CopyFile Folder_Path & "\" & TrgFiles(i), TrgFolder
Folder_Path = .SelectedItems(1) & "\"なので
& "\"これ要りませんね。

.CopyFile Folder_Path  & TrgFiles(i), TrgFolder

めぐみん_ · Answer

＞1. 管理番号［3］[4」のみ階層:「DDD」を作成したい(深い階層のみフォルダを作成したい)
＞参考になりそうなサイトはありますか？

サイトと言うか有無を調べるならDir関数ででも可能かと。
フルパスで階層3の中にフォルダが存在するかって感じで。
https://vbabeginner.net/vba%E3%81%A7%E3%83%95%E3%82%A9%E3%83%AB%E3%83%80%E5%AD%98%E5%9C%A8%E3%83%81%E3%82%A7%E3%83%83%E3%82%AF/

めぐみん_ · Answer

何をしたいのかちょい不明ですよね。

＞このフォルダ内に、100程度のWord又はPDFがあり、

に対してコードが

＞folder1 = "C:\Users\81906\Desktop\マクロテスト\コピー元\"
＞'まずExcelファイルを取得
＞file = Dir(folder1) '最初のファイル

これだとExcelファイルはおろかWordもPDFもフォルダさえも探してはくれないでしょ。

今の状態・目標とする状態のフォルダをツリー形式の要領で図式化して表示されたら伝わりやすいかもしれませんね。

＞If Left(f, 3) = "abc" Then 'ファイル名の中に"abc"があれば

これも何のことなのか？と思ってしまいますし。

Excel VBA ファイルコピー後フォルダ振り分けについて

ご質問や補足を読んでも理解にたどり着けず、気になっていましたので

すみません、メイン処理

＞1. 管理番号［3］[4」のみ階層:「DDD」を作成したい(深い階層のみフォルダを作成したい)

何をしたいのかちょい不明ですよね。

このQ&Aを見た人はこんなQ&Aも見ています

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

このQ&Aを見た人がよく見るQ&A

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

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