エクセルVBAで全てのサブフォルダ内にファイルをコピー

質問

お世話になります。
サブサブフォルダが、100個くらい入ったサブフォルダがさらに20個くらいメインフォルダの中にあります。

エクセルのマクロで、全てのフォルダの中に、
メインフォルダにおいてあるファイルをコピーして入れたいのですが、
どなたかご教授ください。

回答No.1

kigoshi · ベストアンサー

メインフォルダの名前を１行目で定義しています。適宜変更して下さい。
「メインフォルダにおいてあるファイル」というのはエクセルファイルのみかどうか
不明でしたので、とりあえずどんなファイルでもコピーする事にしました。
エクセルファイルのみを対象にしたい場合は、
fName = Dir(MainDir)　　　の行を
fName = Dir(MainDir & "*.xls")　　　に変えて下さい。

Const MainDir As String = "c:\main\"
Dim fCnt, cpCnt As Integer
Sub MainFileSelect()
Dim fName As String
fCnt = 0
fName = Dir(MainDir)
' fName = Dir(MainDir & "*.xls")
Do Until fName = ""
If (GetAttr(MainDir & fName) And vbDirectory) <> vbDirectory Then
fCnt = fCnt + 1
Cells(fCnt, 1).Value = fName
End If
fName = Dir
Loop
Call MainFileCopy(MainDir)
MsgBox (CStr(fCnt) & "個のファイルを合計" & CStr(cpCnt) & "回コピーしました。")
End Sub

Sub MainFileCopy(targetDir As String)
Dim rIdx, dIdx, dCnt As Integer
Dim sDir As String
Dim sDirN(300) As String
sDir = Dir(targetDir, 22)
Do Until sDir = ""
If (GetAttr(targetDir & sDir)) = 16 Then
If (sDir <> ".") And (sDir <> "..") Then
dCnt = dCnt + 1
sDirN(dCnt) = sDir
End If
End If
sDir = Dir()
Loop
For dIdx = 1 To dCnt
Call MainFileCopy(targetDir & sDirN(dIdx) & "\")
Next
If targetDir <> MainDir Then
For rIdx = 1 To fCnt
FileCopy MainDir & Cells(rIdx, 1).Value, targetDir & Cells(rIdx, 1).Value
cpCnt = cpCnt + 1
Next
End If
End Sub

お礼

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