VBAにてフォルダ作成する方法を教えてください

質問

フォルダAにはフォルダ１、フォルダ２、フォルダA９、・・・
といろいろなフォルダがあり、そのフォルダの中には更にいろいろな
ファイルがあります。

フォルダAの中にあるフォルダと同じ名前のフォルダをフォルダBの
中に作りたいのですが、どのようにすればよいか教えてください。

フォルダAを丸ごとコピーして、最後にファイルをすべて消せば良い
のですが、大量にファイルがあって、ハードディスクの容量的にも
時間的にも無理があります。

質問しっぱなしで、恐縮ですがVBAのコードにて回答をお願いします。

回答No.1

hana-hana3 · ベストアンサー

フォルダの作成自体は難しいことではありませんが、別のフォルダと同一の構成のフォルダを再構成するというのは難しく面倒な事になります。

フォルダ名を取り出す事も可能ですが、枝分かれするその下位フォルダ全てを取り出すには、何らかの方法でフォルダ構成を一時的に記憶するとか、再帰などのプログラミング手法が必要になるでしょう。

ネット検索してみてください。
回答ではありませんが、ヒントになるコードかと思います。

http://megalo.jp/gnome/vbnet/vbs02.html
http://makotowatana.ld.infoseek.co.jp/vba_file4.html#FileSystemObject

お礼

回答ありがとうございます。

とりあえずフォルダAの中のフォルダのみでＯＫで、
それより下位は対象としなくてよいとさせてください。

補足

ネットに転がっているコードを探して、
フォルダの一覧を書き出すコードとフォルダを作成するコードを
合体して、とりあえず出来ました。

回答No.2

Wendy02

こんにちは。

こういうものは、一度は、自分でやってみないと分かりませんね。

'-------------------------------------------
Sub NewMakeFolderPr()
　　Dim buf() As String
　　Dim myName As String
　　Dim i As Long
　　Dim v As Variant
　　'-------------------------------------------
　　'パスの最後には必ず、"\"セパレータを入れてください。
　　'元の親パス
　　Const MOTOPATH As String = "C:\"
　　'コピーされる親パス
　　Const NEWPATH As String = "D:\"
　　'-------------------------------------------
　　myName = Dir(MOTOPATH, vbDirectory)
　　Do While myName <> ""
　　　　If myName <> "." And myName <> ".." Then
　　　　　　If (GetAttr(MOTOPATH & myName) And vbDirectory) = vbDirectory Then
　　　　　　　　ReDim Preserve buf(i)
　　　　　　　　buf(i) = Mid$(myName, InStrRev(myName, "\") + 1)
　　　　　　　　i = i + 1
　　　　　　End If
　　　　End If
　　　　myName = Dir()
　　Loop
　　On Error Resume Next
　　For Each v In buf
　　　　MkDir NEWPATH & v
　　Next v
　　If Err.Number = 0 Then
　　　 Beep
　　Else
　　　 MsgBox Err.Description, vbExclamation
　　End If
　　On Error GoTo 0
End Sub

'-------------------------------------------
これは、同じ名前があると、エラーメッセージが出ます。

お礼

回答ありがとうございました。
自分で作るとダラダラとしたコードになってしまうのが常で、
貴殿のようなシンプルなコードがあるのではないかと思い
質問しました。
まあ、個人的に使うだけなので、だらだらコードでも問題は
ないのですが、でもやっぱりカッコ良いコードがほしい。
ということで、色々発展させるための雛形にさせていただきます。
ありがとうございました。