数階層のあるフォルダのコピーを 簡単にするVBA

質問

数階層のあるフォルダのコピーを
簡単にするVBAのプログラムについての
ご質問です
たとえばフォルダがみっつ、フォルダA
フォルダB、フォルダCとあるとします
これらのなかには人物のIDと対応するフォルダがあり
それぞれのフォルダには、そのIDの人物に関する書類pdfが
入っています
たとえばフォルダAにそのサブフォルダとして
サブフォルダ1があり、そのなかにpdfファイルがいくつかあります
サブフォルダ2も同様です
サブフォルダ3，4，・・・・
フォルダBではサブフォルダがサブフォルダ_あ　サブフォルダ_い,,,
とあり、さらにサブフォルダ_あのなかにIDに対応するサブサブフォルダ11，
12.13とあり　それぞれに多種のpdfファイルが入っています
なかには例えばですが、サブフォルダ_いのなかにも、さきほどのフォルダAのなかにあったID2に対応するサブフォルダ2が入っています。
これらをすべて統括するような総合フォルダにIDに対応するフォルダだけで
まとめあげたいという目的なのですが、
上記のフォルダ2のように別の上層階のフォルダから移動するときに、上書きをするか、別名で保存するか問われますが、フォルダ2で統一して、そのかなのpdfファイルに同名のファイルがあれば、片方をそのまま　もう一方を---（1）のような
ファイル名に変換して上書きされないようにしたく思います
数百のフォルダがあるので、なんとかコードで作れないか
お尋ねしたく思います
わかりにくい説明ですみません
簡単な図示を添付致します
すみません
宜しくお願い致します
言い方を変えますと、
個人それぞれがID番号を持っていて、ID番号が名称の
フォルダがあり、そのなかにｐｄｆファイルが任意の数、格納されており、
そのID対応のフォルダが、いくつかのフォルダのなかに分散されていて、
その階層は一定ではないですが、IDフォルダは各フォルダの最下層にあるものであり、
最終的にはすべてのIDgフォルダをひとつの統合フォルダにまとめあげたい。
なかには別フォルダのなかに重複して、あるIDフォルダによっては分散しているので
統合するときに上書きを問われてしまう
それを　ひとつのIDフォルダに統合し、そのなかのpdfファイルも上書きはしないで
別名保存で　そのIDフォルダに保存したい
というわけです
かえってわかりにくくなったかもしれません
宜しくお願い致します

回答No.3

luka3 · ベストアンサー

どうしてもVBAでなければならないのでしょうか。
一度だけ統合してしまえばいいので、言語にこだわる必要がない気がしまして。
ちょうど先週、ファイルを整理するものを作っていたのでそれを少し改造しました。

下記のプログラムをコピーしてメモ帳かテキストエディタに貼り付けて、
『 統合.js 』といったファイル名で保存し、ダブルクリックで実行して下さい。
保存する際は、メモ帳なら文字コードを『ANSI』、エディタなら『シフトJIS』で保存してください。

余計なお世話かもしれませんが、コピーしたファイル名の結果を log.txt に保存します。

var WShell = WScript.CreateObject("WScript.Shell");
var fso = WScript.CreateObject("Scripting.FileSystemObject");
var ForReading=1, ForWriting=2, ForAppending=8;
var slog = "";

//　.jsでは \ を使う時２つ続けて \\ にします
var srcDir = "C:\\統合元フォルダ名\\*.pdf"; // <= 統合元のフォルダ名と対象の拡張子
var dstDir = "C:\\統合先フォルダ名\\"; // <= 統合先のフォルダ名

var files = GetFileList(srcDir);
for (var ia=0; ia<files.length; ia++)
CopyFile(files[ia], dstDir);
if (slog) WriteFile("log.txt", slog);

Err("作業終了");

function GetFileList(pat) { // 指定ファイルの一覧を取得して配列で返す
var tmpfile = "tmp$$$.$$$";
WShell.Run('%comspec% /c dir /s /on /b "' + pat + '">'+tmpfile, 8, true);
if (!fso.FileExists(tmpfile)) Err("not found "+tmpfile);
var str = ReadFile(tmpfile);
fso.DeleteFile(tmpfile);
return str.split(/\r?\n/);
}

function CopyFile(filename, dstDir) { // ファイルコピー
if (!fso.FileExists(filename)) return ;
var m = filename.match(/.*\\(.*)\\(.*)$/); // ファイル名と親フォルダの名前を取得
var newdir = dstDir+m[1]; // コピー先のフォルダ名
var newname = MakeNewName(m[2], newdir); // 新しいファイル名
if (!fso.FolderExists(newdir)) fso.CreateFolder(newdir); // フォルダが無ければ作成
fso.CopyFile(filename, newname);
slog += filename + "\r\n　=>　" + newname + "\r\n";
}

function MakeNewName(name, pdir) { // コピー先の名前を返す　重複する場合は (1) を付加
var newname = fso.BuildPath(pdir, name);
if (fso.FileExists(newname)) { // 同じ名前が存在するか
var basename = fso.GetBaseName(name); // ファイル名主部
var ext = "."+fso.GetExtensionName(name); // ファイル名拡張子
for (var ic=1; ; ic++) {
newname = fso.BuildPath(pdir, basename+" ("+ic+")"+ext);
if (!fso.FileExists(newname)) break; // 存在しなければ終了
}
}
return newname;
}

function ReadFile(filename) { // テキストファイルを読み込んで返す
var s = "";
if (fso.FileExists(filename) && fso.GetFile(filename).Size>0) {
var ts = fso.OpenTextFile(filename,ForReading,true);
s = ts.ReadAll();
ts.Close();
}
return s;
}

function WriteFile(filename, s) { // テキストファイルを書き込む
var ts = fso.OpenTextFile(filename,ForWriting,true);
ts.Write(s);
ts.Close();
}

function Err(msg) {WScript.Echo(msg); WScript.Quit();}

回答No.4

luka3

No.3です。補足です。
保存してすぐ実行するように書きましたが、srcDir dstDirの所は書き換えてから実行してください。
srcDirは下層のサブフォルダの中にあるpdfも全て捜索しますので、フォルダAの1つ上のフォルダを指定してください。

回答No.2

HohoPapa

私だったら、次のような対応をします。

作業１：
統合したいファイルたちのフォルダー、ファイル名などの一覧をリストアップする

作業２：
このリストを指摘のＩＤ順、ファイル名順に並べ替える

作業３：
このリストのファイル名の重複したレコードに、複写先のファイル名をセットする
つまり、
>もう一方を---（1）
を付加する処理です。

作業４：
このリストに従い、指定したフォルダーにファイルを複写する。

試しに、作業１，２を行うVBAのコードを書いてみました。
このマクロで期待のリストアップまでできればゴールは近いと思います。

なお、このマクロは実行の都度、Sheet1に追記しています。
再処理する場合は、Sheet1を空にしてから実行してください。

見ればわかると思いますが、各列に格納している内容を列挙します。

1列目：ファイルの格納フォルダー
2列目：最深フォルダーの親フォルダー
3列目：最深フォルダー　これがIDってことと思います。
4列目：ファイル名
5列目：ファイル名（拡張子以外）
6列目：拡張子　

Option Explicit

'Microsoft Scripting Runtime　を参照設定

Dim PutRow As Long
Dim PutSh As Worksheet

Sub sample()
Set PutSh = ThisWorkbook.Sheets("Sheet1")
If PutSh.Cells(1, 1).Value = "" Then
PutRow = 1
Else
PutRow = PutSh.Cells(Rows.Count, 1).End(xlUp).Row
End If
getFilesRecursive "D:\TESTA\Sample" '<==ここに親フォルダーを記述

PutSh.Select
Cells.Select

PutSh.Sort.SortFields.Clear
PutSh.Sort.SortFields.Add2 Key:=Range("C1:C1") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
PutSh.Sort.SortFields.Add2 Key:=Range("D1:D1") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With PutSh.Sort
.SetRange Range("A1:F30000")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

End Sub

Sub getFilesRecursive(path As String)

Dim fso As FileSystemObject: Set fso = New FileSystemObject
Dim objFolder As folder
Dim objFile As file

'フォルダ配下のフォルダ一覧を取得
For Each objFolder In fso.GetFolder(path).SubFolders
getFilesRecursive (objFolder.path)
Next

'フォルダ配下のファイル一覧を取得
If isDeepDir(fso.GetFolder(path)) = True Then
For Each objFile In fso.GetFolder(path).Files
execute objFile, path
Next
End If

End Sub

Sub execute(f As file, p As String)

Dim wStr1() As String
Dim wStr2 As String
Dim ACnt As Long
Dim c As Long
Dim fso As New Scripting.FileSystemObject
Dim filePath As String
Dim ExtentionName As String

wStr1 = Split(p, "\")
ACnt = UBound(wStr1)
For c = 0 To ACnt - 1
wStr2 = wStr2 & wStr1(c) & "\"
Next c
PutSh.Cells(PutRow, 1).Value = p
PutSh.Cells(PutRow, 2).Value = wStr2
PutSh.Cells(PutRow, 3).Value = wStr1(ACnt)
PutSh.Cells(PutRow, 4).Value = f.Name
ExtentionName = fso.GetExtensionName(f)
PutSh.Cells(PutRow, 5).Value = Left(f.Name, Len(f.Name) - Len(ExtentionName) - 1)
PutSh.Cells(PutRow, 6).Value = ExtentionName
Set fso = Nothing
PutRow = PutRow + 1

End Sub

'//フォルダーが子フォルダーを持たないフォルダーか？を判定する関数
Function isDeepDir(tgDir As String) As Boolean
Dim fso As FileSystemObject: Set fso = New FileSystemObject
Dim objFolder As folder
Dim HitCnt As Long

HitCnt = 0
For Each objFolder In fso.GetFolder(tgDir).SubFolders
HitCnt = HitCnt + 1
Next
If HitCnt = 0 Then
isDeepDir = True
Exit Function
End If

End Function

期待通りなら、作業３，４のコードを書きます。

回答No.1

t_hirai

ランサーズとかでエンジニアさんに依頼するとか。。。

お礼

ランサーズ＞＞そういうのがあるのですね　有り難うございました。

Powered by GRATICA