こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

エクセルマクロで、フォルダ内のファイル移動をしたい

写真整理フォルダの下に、大項目フォルダがあります。
その中に、月フォルダがありその中に日付フォルダがあります。
その日付フォルダの中に細項目でフォルダ分けされてそれぞの中にjpgファイルが
入っています。
今回は、その細項目で整理されたjpgファイルを日付フォルダの直下へ移動したいのです。
共有フォルダを、指定しようとすると階層が深いのでこのフォルダ内の各日付フォルダに
入っているフォルダの中のjpgファイルを日付フォルダへ移動せよというのが
エクセルのマクロで命令出来ればと思っているのですが。
3万件以上を処理しないといけないのでとても困っています。
コードのご教示宜しくお願い致します。

投稿日時 - 2018-11-17 12:56:38

QNo.9558800

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(4)

ANo.4

再帰プロシージャを使うコードとしてみました。
また、
>重複ファイルが、あるかないかと言われると分からないのですが
この場合、先勝ちとし、後負けとなったファイルは
そのまま残し、ファイル名のフルパスを
シートに書き込むようにしてみました。

実際に対象とするフォルダー構造を明示してもらえないので
テストしていません。
事前に控えを取得するとか、
十分なテストをしたうえで使ってみてください。



Option Explicit

Const EnKazu = 6 '日付フォルダーの深さ(\の数)
Const tgDir = "D:\色々\写真集"

Dim RowCouunter As Long


'// これを起動する===========
Sub FileMoveMain()
 RowCouunter = 1
 Call FLMove(tgDir)
End Sub

'// ===========
Sub FLMove(Path As String)
 Dim buf As String, f As Object
 buf = Dir(Path & "\*.*")
 Do While buf <> ""
  If FileExists(GetOyaDir(Path, EnKazu) & buf) = True Then
   RowCouunter = RowCouunter + 1
   ThisWorkbook.Sheets(1).Cells(RowCouunter, 1).Value = _
    Path & "\" & buf
  Else
   If GetOyaDir(Path, EnKazu) <> "" Then
    Name Path & "\" & buf As GetOyaDir(Path, EnKazu) & buf
   End If
  End If
  buf = Dir()
 Loop
 With CreateObject("Scripting.FileSystemObject")
  For Each f In .GetFolder(Path).SubFolders
   Call FLMove(f.Path)
  Next f
 End With
End Sub

'// 日付フォルダー名取得関数
Function GetOyaDir(FullDir As String, Kaiso As Long) As String
 Dim wkCnter As Long
 Dim wkDir As String
 Dim wkPos As Long
 wkDir = FullDir
 wkPos = 1
 GetOyaDir = ""
 For wkCnter = 1 To Kaiso
  wkPos = InStr(wkPos + 1, wkDir, "\")
 Next wkCnter
 If Len(Left(FullDir, wkPos)) > Len(tgDir) Then
  GetOyaDir = Left(FullDir, wkPos)
 End If
End Function

'// ファイル有無判定関数
Function FileExists(ChkFile As String) As Boolean
 FileExists = True
 On Error GoTo ErrorHandler
 FileDateTime (ChkFile)
 On Error GoTo 0
 Exit Function
ErrorHandler:
 FileExists = False
 Resume Next
End Function

投稿日時 - 2018-11-18 12:01:57

ANo.3

階層下のディレクトリー=サブディレクトリーも含めて一括で削除するなら
『rd /s /q ディレクトリ名』を利用します。

以下参照
https://www.k-tanaka.net/cmd/rd.php

移動する場合にファイル名が重複する場合が合ってもファイラーを利用して
 同名ファイルがある場合、変名するようにファイラー側で設定すれば問題はありません。

投稿日時 - 2018-11-18 05:56:47

ANo.2

>日付フォルダの中に細項目でフォルダ分けされて
日付フォルダの下階層に複数階層のフォルダーがありますか?

>日付フォルダの直下へ移動したいのです
ここに集まることでファイル名が重複することはないんでしょうか?

また、
後に示すような書き方などでサンプル表示し
さらに、どのような結果にしたいのかも説明してほしいところです。

更に、
日付フォルダの直下へ移動することで
その下階層に、空のフォルダーが残るわけですが
このフォルダーたちは手作業で削除する予定ですね?


D:\色々
┗\写真集
 ┗\海
  ┗\201801
   ┗\01
    ┗\東北
     ┗\ABC.jpg
     ┗\DEF.jpg
     ┗\青森
      ┗\100.jpg
     ┗\秋田
      ┗\100.jpg
      ┗\200.jpg
   ┗\02
    ┗\東北
     ┗\FGH.jpg
     ┗\HIJ.jpg
     ┗\青森
      ┗\500.jpg
     ┗\秋田
      ┗\600.jpg
      ┗\700.jpg
 ┗\山
  ┗\201801
   ┗\01
    ┗\東北
     ┗\ABC.jpg
     ┗\DEF.jpg
     ┗\青森
      ┗\100.jpg
     ┗\秋田
      ┗\100.jpg
      ┗\200.jpg
   ┗\02
    ┗\東北
     ┗\FGH.jpg
     ┗\HIJ.jpg
     ┗\青森
      ┗\500.jpg
     ┗\秋田
      ┗\600.jpg
      ┗\700.jpg

投稿日時 - 2018-11-17 18:05:33

補足

D:\色々
┗\写真集
 ┗\海
  ┗\201801
   ┗\01
    ┗\ABC.jpg
    ┗\DEF.jpg
    ┗\100.jpg
    ┗\100.jpg
    ┗\200.jpg
     ┗\東北
     ┗\青森
     ┗\秋田
と、言うようになるのが最終形です。
01フォルダ内に、あるフォルダは現状そのままです。
(たぶん、最終的には削除するんだとは思いますがどんなフォルダが
あったのかを確認することがあるのでとりあえずはそのままです。

日付フォルダの下階層は、階層はありません。日付フォルダの中に、複数フォルダがありその中にはjpgファイルが入っているだけです。
(上記で、書いていただいた感じになっています。)
重複ファイルが、あるかないかと言われると分からないのですが(色々な人が同じメーカーのデジカメで撮ったものを集結させるのでないとは言えません。ただし、数枚上書きされたところでそれがあったのかなかったのかは誰にも分かりません。と、割り切るしかないですね)
もし、捜索することになっても同じ名前だから上書きされたんだねってことにしかならないんですよね。工事写真の関係上、写真の名前を変更すると不正写真となりエラーするので・・・。

投稿日時 - 2018-11-18 09:03:13

ANo.1

それは、必ずexcelのマクロ(VBA)で処理しなければなりませんか?

単純にエキスプローラーやファイラーで処理すれば
 ターゲットを日付フォルダーにしてそれより深い階層のファイルを全て
  ターゲットフォルダーに移動できますが?

この処理で少しは手抜きができます。

以下は、私が質問したときのURLです。

検索ワード:種類:NOT フォルダー
 https://okwave.jp/qa/q9555043.html

投稿日時 - 2018-11-17 15:30:05

あなたにオススメの質問