複数フォルダ内のファイル群をひとつに纏める

質問

Excel2003のVBA で、以下の作業を行いたいので宜しくご教示下さい。

　　サーバー上や自分のPC上にある、任意フォルダA直下には、
　　複数のフォルダがあり、その複数フォルダ内に多数のファイル（約３万個）が入っている。
　　そのファイル群を、任意フォルダAの直下に新しいフォルダを１つ作り、全てコピーし纏めたい。

　　当方の構想（希望）としては、
　　１．エクセルシート１に全ファイル名を書きだす。（行：フォルダ名、列：ファイル名）
　　２．同名ファイルの有無を判定し、有ればエクセルシート２にフォルダ名とファイル名を抽出する。
　　　　（同名ファイルは、エクセルシート２を確認し、手動で変更する）
　　３．同名ファイルが無ければ、新しいフォルダに全てコピーする。

コードを記載しご教示頂ければ助かります。
皆様よろしくお願い致します。

回答No.3

mitarashi · ベストアンサー

#2の続きです。
1番目のシートにファイルリストを出力（形式はご質問の仕様と異なります）→日付と、サイズも出力しますので、こちらでファイル名をキーに並び替えして重複チェックする事をお勧めします。
2番目のシートに、重複したファイル名と、フォルダー名（，区切りで列挙）を出力します。
xl2000とxl2010で動作を確認しました。（ファイルコピー部分はあまり試してないです）。但しxl2000はTranspose関数が配列の要素数4095個までしか対応しておりません。それから、4G以上のファイルにも対応していません。
xl2010で、2万個位のファイルの抽出（コピーを除く）が2分未満でした。（但し、Dドライブ、Celeron2.4GHz)#1で紹介されているFileSystemObjectが遅く感じたら、使ってみてください。
APII部分はWEB上の情報の切り貼りなので質問されても答えられませんのでよろしく。また、文字数制限対策で、エラー処理とか色々削ってありますので、ご承知置き下さい。
'ファイルを検索する
Private Sub FindFile( _
ByVal DirPath As String, _
ByVal SearchFileName As String, _
ByRef filePath() As String, _
ByRef fName() As String, _
ByRef updateDate() As Date, _
ByRef fileSize() As Long, _
Optional ByVal CheckSubFolder As Boolean = False _
)
Dim wfd As WIN32_FIND_DATA
Dim hFind As Long
Dim i As Long
Dim j As Long
Dim DirName As String
Dim myFileName As String
Dim SubFolders() As String

' パス終端の補正
If Right$(DirPath, 1) <> "\" Then DirPath = DirPath & "\"
' サブフォルダ列挙
i = -1
If CheckSubFolder Then
hFind = FindFirstFile(DirPath & "*", wfd)
If hFind <> INVALID_HANDLE_VALUE Then
Do
DirName = Left$(wfd.cFileName, InStr(wfd.cFileName, Chr(0)) - 1)
If DirName <> "." And DirName <> ".." Then
If CBool(wfd.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
i = i + 1
ReDim Preserve SubFolders(i)
SubFolders(i) = DirPath & DirName
End If
End If
Loop Until FindNextFile(hFind, wfd) = 0
FindClose (hFind)
End If
End If
' ファイル列挙
hFind = FindFirstFile(DirPath & SearchFileName, wfd)
If hFind <> INVALID_HANDLE_VALUE Then
Do
myFileName = Left$(wfd.cFileName, InStr(wfd.cFileName, Chr(0)) - 1)
If myFileName <> "." And myFileName <> ".." Then
If CBool(wfd.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = False Then
On Error Resume Next
j = UBound(fName) + 1
If Err Then j = 0
On Error GoTo 0
ReDim Preserve filePath(j)
ReDim Preserve fName(j)
ReDim Preserve updateDate(j)
ReDim Preserve fileSize(j)
filePath(j) = DirPath
fName(j) = myFileName
updateDate(j) = FILETIME2Date(wfd.ftLastWriteTime)
'4GB以下であれば、nFileSizeHighは無視できる
fileSize(j) = wfd.nFileSizeLow
j = j + 1
End If
End If
Loop Until FindNextFile(hFind, wfd) = 0
FindClose (hFind)
End If
' サブフォルダ探索
If CheckSubFolder And i > -1 Then
For i = 0 To UBound(SubFolders)
' サブフォルダ再帰呼び出し
Call FindFile(SubFolders(i), _
SearchFileName, _
filePath, _
fName, _
updateDate, _
fileSize, _
CheckSubFolder)
Next i
End If
End Sub

'FILETIME構造体をDate型に変換
Private Function FILETIME2Date(udtFileTime As FILETIME) As Date
Dim udtLclTime As FILETIME 'ローカル時間補正後
Dim udtSysTime As SystemTime
Dim dummyRetVal As Long

dummyRetVal = FileTimeToLocalFileTime(udtFileTime, udtLclTime)
dummyRetVal = FileTimeToSystemTime(udtLclTime, udtSysTime)
With udtSysTime
FILETIME2Date = CDate(.wYear & "/" & .wMonth & "/" & .wDay & " " & _
.wHour & ":" & .wMinute & ":" & .wSecond)
End With
End Function

お礼

コード記載ありがとうございます。
大変感謝しております。

内容については、ひとつひとつ確認して実行して行きたいと思います。
（はっきり、私の能力では解読出来ないかも知れませんが…。）

＞「ちょっと興味があったので・・・」
本当に興味を持って頂きありがとうございました。
コア（？）な、質問で回答無しかなと思っていましたし。
時々参考にしていたサイトなので、皆様の実力には感服していた次第です。
今回の質問は、かなり手こずった（糸口が見えない）末の投稿でした。

ベストアンサーだと思いますが、解読してみてからのチェックとさせて下さい。
（かなり時間がかかると思います）

回答No.7

imogasi

コピー元（移動元）対象ファイルに付いて
>多数のファイル（約３万個）が
写し（移し）たくないファイルが混じってあるのかな。
エクセルファイルばかりではないのかな。
ファイル名の先頭とかに選別の印（文字列）は無いのか
ーーー
除外ファイルが少なければ、フォルダ単位で、１つのフォルダ内に写すか移したら。
そこで不要のファイルを道家手削除する（出来ればプログラムロジックでプログラムを組んで）。
トイのも３００００ファイルも扱うとＶＢＡのようなインターｐリター的な処理では、時間が大変かかるような気がする。
ーー
＞クセルシート１に全ファイル名を書きだす
出来るならここから手を付けたら。
Ｇｏｏｇｌｅで「ＶＢＡ　フォルダ　ファイル名　取得」で照会したのかな。沢山コードレが出るに、１０行以内で済む。
ドレくらい時間がかかるかとか、ダブリの情況が実感できるだろう。
１シートに複数フォルダのファイル名（フォルダ名＋ファイル名）も累積できるだろう。
この複数フォルダ名は、セル範囲に入れるか配列に定義する。１０－２０ぐらいかと予想。質問異は複数とあいまいにせず、２０ファオルダとか概数を書けば良いのに。
そしてソートしてプログラムでチェックしてサインで別列に出して、詳細は質問者がチェックする

お礼

かなりお礼が遅くなりすみません。
大変参考となりました。

回答No.6

mitarashi

#2です。
更に悪のりして、

ファイルをコピーするSHFileOperationというAPIがあります。
http://homepage2.nifty.com/Dee/vb/soft/index.html
フォルダの異なる複数ファイルをコピーするには、パスをChr(0)を介して結合し、最後にChr(0)を二個つけた文字列を生成して与える必要があります。My Documentsに置いたファイルのフルパス1800個程度では動作しました。
残念ながら、VBAのファイルコピーに対して速度上のメリットはなさそうですが、お馴染みのファイルをコピーするアニメーションのダイアログで進度表示されるので、気が紛れるというメリットは期待できます。
ご参考まで。

バグフィックス
重複ファイルが一つもないと、シート2への転写部でコケるので、

If myDic2.Count > 1 Then
Sheets(2).Range("A1").Resize(myDic2.Count, 1) = Application.Transpose(myKeys)
Sheets(2).Range("B1").Resize(myDic2.Count, 1) = Application.Transpose(myItems)
End If

と、条件を加えてください。
また、Thumbs.db（システムファイルでフォルダオプションをいじらないと見えない）で、コピーエラーが出る事がある様です。
ご参考まで。

回答No.5

mitarashi

#2です。
調子にのってファイルの同一チェックをハッシュを求めて行う方法を調べておりました。
参考URLの関数を借用してやってみました。#2のコードの最後の方に組み込みます。
http://su-u.jp/juju/%B5%A4%A4%DE%A4%B0%A4%EC%C6%FC%B5%AD/2007-03-08.html
すべてPublicで宣言してくれてあるので、丸ごとModule2などにペーストすればよいでしょう。
あまり深く試してはありませんが、一応動くのは確認しました。ご参考まで。
（変数宣言部は含みませんので試すときはご自分でお願いします）

myKeys = myDic2.keys
For Each mykey In myKeys
buf = Split(myDic2.Item(mykey), ",")
For i = LBound(buf) To UBound(buf)
srcFileName = buf(i) & "\" & mykey
myHash = CreateSHA1HashFile(srcFileName) 'ハッシュの算出は数種類サポートされています。
destFileName = destpath & "\" & Left(mykey, InStr(mykey, ".") - 1) _
& "_" & myHash & Right(mykey, Len(mykey) - InStr(mykey, ".") + 1)
If Dir(destFileName) = "" Then
FileCopy srcFileName, destFileName
End If
Next i
Next mykey

お礼

かなり遅くなりました（パスワードがわからなくなっていました）
ハッシュもわかるのですね。これは凄い！なんらかの参照にさせて頂きます。

回答No.4

sknbsknb2

お求めの回答ではありませんが、よりよい方法を提示できる可能性もあるのでお聞きします。

世の中にはご希望の動作をするユーティリティがいくつもあると思うのですが、それをEXCELのVBAで実行したいというのは何か理由があるのですか？

お礼

ご覧頂きありがとうございます。
なんらかのユーティリティは世の中に存在するとは思いましたが
（自宅での）検索する時間が惜しく・・・

　また、会社のセキュリティ（不要サイト閲覧禁止、ダウンロード禁止etcetc...）上で
融通が利かない状況です。
当方が強く推せば、特定のユーティリティを使えると思いますが。

この様な、（無駄な）理由でＶＢＡでの実行に思いが行き当っているのでございます。

回答No.2

mitarashi

ちょっと興味があったので、作成してみました。4K文字に収まらないので、二つに分けます。コメントは別途。

Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindClose Lib "kernel32" ( _
ByVal hFindFile As Long) As Long
Declare Function ShellExecute Lib "SHELL32" Alias "ShellExecuteA" (ByVal hwnd&, ByVal lpOperation$, ByVal lpFile$, ByVal lpParameters$, ByVal lpDirectory$, ByVal nShowCmd&) As Long
Declare Function LocalFileTimeToFileTime Lib "kernel32" _
(lpLocalFileTime As FILETIME, _
lpFileTime As FILETIME) As Long
Declare Function FileTimeToLocalFileTime Lib "kernel32" _
(lpFileTime As FILETIME, _
lpLocalFileTime As FILETIME) As Long
Declare Function FileTimeToSystemTime Lib "kernel32.dll" _
(lpFileTime As FILETIME, lpSystemTime As SystemTime) As Long

Const MAX_PATH As Long = 260
Const INVALID_HANDLE_VALUE As Long = (-1)
Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10
Const conDayZeroBios As Double = 109205#
Const conMillisecondPerDay As Double = 10000000# * 60# * 60# * 24# / 10000#

Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type

Type SystemTime
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type

Sub makeFileList()
Dim j As Long, i As Long
Dim filePath() As String, fName() As String
Dim updateDate() As Date
Dim fileSize() As Long
Dim fieldName
Dim myDic As Object, myDic2 As Object
Dim myKeys, myItems, myKey

Const myFolder As String = "C:\hoge"

Call FindFile(myFolder, "*.*", filePath(), fName(), updateDate(), fileSize, True)
On Error Resume Next
j = UBound(fName) + 1
If Err.Number <> 0 Then Exit Sub
On Error GoTo 0

With Sheets(1)
.Cells.Clear
fieldName = Array("Path", "Name", "UpdateDate", "Size")
.Range("A1").Resize(1, 4) = fieldName
.Range("A2").Resize(j, 1) = Application.Transpose(filePath)
.Range("B2").Resize(j, 1) = Application.Transpose(fName)
.Range("C2").Resize(j, 1) = Application.Transpose(updateDate)
.Range("D2").Resize(j, 1) = Application.Transpose(fileSize)
End With

Set myDic = CreateObject("Scripting.Dictionary")
Set myDic2 = CreateObject("Scripting.Dictionary")
For i = 0 To UBound(fName)
If myDic.exists(fName(i)) Then
myDic.Item(fName(i)) = myDic.Item(fName(i)) & "," & filePath(i)
If myDic2.exists(fName(i)) Then
myDic2.Item(fName(i)) = myDic.Item(fName(i))
Else
myDic2.Add fName(i), myDic.Item(fName(i))
End If
Else
myDic.Add fName(i), filePath(i)
End If
Next i
myKeys = myDic2.keys
myItems = myDic2.items
Sheets(2).Range("A1").Resize(myDic2.Count, 1) = Application.Transpose(myKeys)
Sheets(2).Range("B1").Resize(myDic2.Count, 1) = Application.Transpose(myItems)
myKeys = myDic.keys
For Each myKey In myKeys
If Not myDic2.exists(myKey) Then
FileCopy myDic.Item(myKey) & "\" & myKey, "C:\destination\" & myKey
End If
Next myKey
MsgBox "処理終了"
End Sub

回答No.1

temtecomai2

<ファイルの書き出し>
FileSystemObject を使用する。
http://www.google.co.jp/search?hl=ja&q=filesystemobject+%E5%86%8D%E5%B8%B0&lr=lang_ja
ファイル名は File オブジェクトの Name プロパティ値。
フォルダ名は File オブジェクトの ParentFolder プロパティから得られる Folder オブジェクトの Path プロパティ。

<重複チェック>
ソートして 1行上のセルと比べてファイル名が同じか判断する

<ファイルのコピー>
A列 と B列を合体させてコピー元ファイルのフルパスを生成。
「何等かのパス」と B列を合体させてコピー先ファイルのフルパスを生成。
FileSystemObject オブジェクトの CopyFile メソッドを使用する。
http://msdn.microsoft.com/ja-jp/library/cc428016.aspx

コード記載なんて甘えないでがんばってください。

お礼

ヒントになる事項をお答え下さりありがとうございます。
「コード記載・・・」については、色々反応があると予測はして
おりましたが、励ましのお言葉で助かりました＾＾

VBAについては、まったくの初心者でもないですが、独学（ほとんどの方がそうかも？）
でして、私は基本がなっていないのです。
今回の質問は、やりたい事をやりたいにも、「全く糸口が見付からず」、投稿した次第です。