エクセル：マクロでの同名ファイル検索

質問

お世話になります。
あるフォルダの中に、たくさんフォルダが入っています。
子フォルダのファイルを全て親フォルダに移すのですが、同名ファイルがある可能性があります。
同名ファイルは枝番をつけるなどして処理するのですが、あらかじめ同名ファイルがあるかどうかを調べたいのです。
親フォルダの中にエクセルを入れておき、マクロの実行の結果、エクセルのシートに同名ファイルの情報を表示できればと思っています。

例）もし同名ファイルがあった場合、
まずセルＡ１にファイル名、Ｂ１に拡張子を表示する。123.xlsの場合　Ａ１に123　Ｂ１に.xls　そしてそのファイルが入っているフォルダ名をＢ２以降のＢ列に表示する。
３つのフォルダにＡ１のファイル名のデータがあれば、Ｂ２，Ｂ３，Ｂ４にそのフォルダ名が表示される。
もちろん同名ファイルが１組とは限りません。
２つ目以降はＢ列のフォルダ名が入った下の行のＡ列（上の例だとＡ５）にファイル名が入る。
この繰り返しです。
また、もし１つの同名ファイルがなかった場合は、Ａ１に「同名ファイルなし」と表示させます。

ちなみに重複の場合の枝番の付け方に規則性がないため手作業で行いますが、枝番をつけて同名ファイルを無くした
あとにまとめて親フォルダに全データを移すこともマクロで可能ならアドバイスください。
フォルダ構成は１つの親フォルダに対して複数の子フォルダで、孫フォルダはありません。
ＯＳはWinXP、Excelは2002です。
よろしくお願いします。

回答No.3

ham_kamo · ベストアンサー

No.2です。

ファイル移動のマクロで、移動中のファイルの進行状況を左下のステータスバーに表示し、終了したらダイアログを出すとともにB1に「移動完了しました」と出すようにしてみました。マクロを以下のものに差し替えて試してください。

Sub ファイル移動()
　Dim RootPath As String
　Dim i As Integer
　Dim FSO As Object
　Dim D As Object, F As Object

　Set FSO = CreateObject("Scripting.FileSystemObject")
　RootPath = ThisWorkbook.Path & "\"

　i = 1
　For Each D In FSO.GetFolder(RootPath).SubFolders
　　For Each F In FSO.GetFolder(RootPath & D.Name).Files
　　　Application.StatusBar = "ファイル移動中: " & i & "ファイル完了 "
　　　Name RootPath & D.Name & "\" & F.Name As RootPath & F.Name
　　　i = i + 1
　　Next
　Next
　Set FSO = Nothing
　Application.StatusBar = ""
　MsgBox ("終了しました。")
　ActiveSheet.Range("B1").Value = "移動完了しました。"
End Sub

お礼

ありがとうございました。希望通りにいきました。

回答No.2

ham_kamo

ちょうど先日に同じようなものを作ったので、それを流用して作ってみました。

●同名ファイルの抽出マクロ

Sub 重複ファイル抽出()
　Dim RootPath As String
　Dim i As Integer
　Dim IsDuplicated As Boolean
　Dim FSO As Object
　Dim D As Object, F As Object
　Dim r As Range
　Dim TmpWS As Worksheet, WS As Worksheet

　Application.ScreenUpdating = False
　Set WS = ActiveSheet
　WS.Cells.ClearContents

　'ワーク用のテンポラリシートを追加
　Set TmpWS = Worksheets.Add

　Set FSO = CreateObject("Scripting.FileSystemObject")
　RootPath = ThisWorkbook.Path & "\"

　'ファイル一覧をテンポラリシートに出力
　'A列：フォルダー名、B列、ファイル名
　i = 1
　For Each D In FSO.GetFolder(RootPath).SubFolders
　　For Each F In FSO.GetFolder(RootPath & D.Name).Files
　　　Cells(i, "A").Value = D.Name
　　　Cells(i, "B").Value = F.Name
　　　i = i + 1
　　Next
　Next

　'ファイル名をキーにしてソート
　Columns("A:B").Sort Key1:=Range("B1")

　'同名ファイルがあるかチェック
　i = 0: IsDuplicated = False
　For Each r In Range("B1", Cells(Rows.Count, "B").End(xlUp))
　　If StrConv(r.Value, vbLowerCase) = StrConv(r.Offset(1).Value, vbLowerCase) Then
　　　If IsDuplicated = False Then
　　　　i = i + 1
　　　　WS.Cells(i, 1).Value = FSO.GetBaseName(r.Value)
　　　　WS.Cells(i, 2).Value = FSO.GetExtensionName(r.Value)
　　　　IsDuplicated = True
　　　End If
　　　i = i + 1
　　　WS.Cells(i, 2).Value = r.Offset(, -1).Value
　　ElseIf IsDuplicated Then
　　　i = i + 1
　　　WS.Cells(i, 2).Value = r.Offset(, -1).Value
　　　IsDuplicated = False
　　End If
　Next

　If i = 0 Then
　　WS.Range("A1").Value = "同名ファイルなし"
　End If

　'テンポラリシートを削除
　Application.DisplayAlerts = False
　TmpWS.Delete
　Application.DisplayAlerts = True
　Set FSO = Nothing
End Sub

●子フォルダ配下のファイルをまとめて移動するマクロ

Sub ファイル移動()
　Dim RootPath As String
　Dim i As Integer
　Dim FSO As Object
　Dim D As Object, F As Object

　Set FSO = CreateObject("Scripting.FileSystemObject")
　RootPath = ThisWorkbook.Path & "\"

　i = 1
　For Each D In FSO.GetFolder(RootPath).SubFolders
　　For Each F In FSO.GetFolder(RootPath & D.Name).Files
　　　Name RootPath & D.Name & "\" & F.Name As RootPath & F.Name
　　　i = i + 1
　　Next
　Next
　Set FSO = Nothing
End Sub

補足

回答ありがとうございます。試した結果、両方とも問題なく動作してくれました。ありがとうございます。ちなみに「子フォルダ配下のファイルをまとめて移動するマクロ」で処理完了後にＢ１セルに「移動完了しました」などと表示できますか？数千件のデータを移動させたりするので・・・

回答No.1

zap35

ここまでガチガチに個人的なＡＰを要求するのですか^^;
別の方法をお教えしますので試してみてください。

COMMAND画面を起動して
>D:　Enter　→　目的のドライブ名
>CD \aaa Enter　→　親フォルダ名
>TREE /F > D:\TREE.TXT　Enter　→　ファイルTreeを二にのファイルに書きだす
>EXIT　→　COMMANDを終わる

これでD:\TREE.TXTというファイルができあがります。内容をみると子フォルダも含めてファイルリストが入っているはずです。
これをEXCELで読み込みます。すると全てがＡ列に読み込まれるはずです。（テキストファイルウィザード経由です）

次に何文字か置換します。置換ウィザードはCtrl＋Hで起動します。
「─」　→　「\」（置換後の文字に半角￥を指定）
「│」　→　「ブランク」（置換後の文字に何も入れずに置換）
「├」　→　「ブランク」
「└」　→　「ブランク」
「半角スペース」→「ブランク」

ここまでの操作でＡ列にファイル名がきれいに入ります。頭に「￥」が着いているのは子フォルダです。

Ｂ１に以下の式を入れて下方向にコピーすると、結果が２以上の項目が重複している項目ということになります。
=COUNTIF(A:A,A1)

お礼

ありがとうございました。