Explorerのホルダー製作VBAの実行バッチ出来ますか

質問

ExcelのA1に C:\イ
B1に朝
B2に昼
B3に晩　と記入し以下のBVAを実行すると　
「朝」「昼」「晩」と ホルダーが3個作れるのを教わりましたが、
C:\イからロハニ.....と十数個のディレクトリがあるとき全てに朝昼晩名の3個のホルダを作るバッチファイル 出来ますか？　
お助けください。

Sub DirListUp()
Dim FPath, SubFld, Fld, RW
FPath = Range("A1").Value
If FPath <> "" Then
Set SubFld = CreateObject("Scripting.FileSystemObject") _
.GetFolder(FPath).SubFolders
RW = 1
For Each Fld In SubFld
Range("B" & Format(RW)) = Fld.Name
RW = RW + 1
Next
End If
End Sub

回答No.7

Wendy02 · ベストアンサー

こんばんは。

何が正しくて何が間違いなのか分からなくなってきて、ちょっと不安になってきてしまいました。
かなり深くなってきたので、これでよいのかなって思いました。

>ExcelのA1＝A　A2＝B　A3＝C　のフォルダ名の時　
>ぶる下がるフォルダを
>G１～P１（あいうえおか）
>G２～J２（きくけこ）
>G３～I３（さしす）

実は、これは簡単に出来たのですが、少し戻って整理しないといけなくなりました。

B列のロング名のフォルダー名に対して、
　－A列の新しいサブフォルダを作ります。

G列～右に1行の中にある文字に対して、
　－A列の新しいサブフォルダの孫フォルダを作ります。

単純な内容なのですが、奇妙なコードのような気がしてきます。^^;

以下は、子のサブフォルダがない時は、それを作ってから、次に孫フォルダを作るように作られています。なお、これは、NewSubFolder の位置は、点線で囲まれた中にありますから、適当に換えられます。
ただし、孫フォルダの行は、新しいサブフォルダの行とが一致していないといけません。

ちょっと試してみてください。

'------------------------------------------------------
Sub CreateUnderSubFolder()
'WriteDir2 と CreateDir2の二つを共に使用する
'サブフォルダの下に孫フォルダを作るマクロ
Dim NewSubFolders As Range
Dim StCol As Integer
Dim i As Integer, j As Integer, k As Integer
'----------------------------------------
'A1からA30までに空白セルなしに入れる－この下に孫フォルダ(孫F)を作る
　Set NewSubFolders = Range("A1", Range("A30").End(xlUp))
　Const STARTCOL As String = "G" '孫F開始列
'----------------------------------------
'列の数字変換
If Not IsNumeric(STARTCOL) Then
　　　StCol = Range(STARTCOL & "1").Column
Else
　　　StCol = CInt(STARTCOL)
End If

　For i = 1 To Range("B65536").End(xlUp).Row
　 For j = 1 To NewSubFolders.Rows.Count
　　　Do While NewSubFolders.Cells(j, StCol + k).Value <> ""
　　　'最初にサブフォルダをチェック
　　　If Dir(Cells(i, 2).Value & "\" & NewSubFolders(j, 1).Value, vbDirectory) = "" Then
　　　　 MkDir Cells(i, 2).Value & "\" & NewSubFolders(j, 1).Value
　　　End If
　　　'次に孫F をチェック
　　　If Dir(Cells(i, 2).Value & "\" & NewSubFolders(j, 1).Value & "\" & _
　　　　NewSubFolders.Cells(j, StCol + k).Value, vbDirectory) = "" Then
　　　　MkDir Cells(i, 2).Value & "\" & NewSubFolders(j, 1).Value & "\" & _
　　　　　NewSubFolders.Cells(j, StCol + k).Value
　　　 End If
　　　 k = k + 1
　　　Loop
　　　k = 0
　 Next j
　Next i

End Sub

※なお、これに対する削除プログラムは、ちょっと複雑になりそうです。

お礼

ヤッホーです。出来ました！！
とりあえずご報告。帰宅後　色々試してみます。
ありがとうございました。
感謝。

補足

帰宅後 色々試してみましたが　CreateUnderSubFolder() は
私の望み通りで大変な満足と感謝をしております。内心でヤッホーと再び歓喜しました。ありがとうございました。
削除は親フォルダごとexplorerで手動で行い新規に作れば良いとします。
発見したこと！
WriteDir2()　で
　BrowseForFolder(0, "フォルダを選択してください", &H0, "C:\")
を”E:\”にすればEドライブの中で『フォルダを選択してください』に出来ますが（ミスタッチで）[C]が[スペース]に置き換わるとデスクトップやマイコンピューター以下全てのドライブが選択可能になりました。便利なので"C:\"を " :\"としました。

質問の時バッチ出来ますかと書きましたのは,
回答者harlan様よりフォルダ作りバッチをご案内されたからです。

＞メモ帳などのテキストエディタで、以下のような内容のファイルを作り　拡張子を「.bat」にして保存します。
md "TestA"
md "TestB"
md "TestC
このファイルを、フォルダを作成したい場所に置き、ダブルクリックで実行します。

　　これはビックリでした。もっと色々explorerを操作する方法ないか？と夢が膨らみましたが、メモ帳に書いて拡張子だけbatではそう複雑には出来ないとだろうと思い、BVAの実行バッチ出来ますか になりました。それ故
Wendy02様には大変なご面倒をおかけしていまいました。お詫びいたします。恐縮しつつも、
お答え頂くうれしさと 出来た時の感動と さらに募る欲で
しがみついてしまいました。
ごめんなさい。そして　たいへんありがとうございました。

回答No.8

Wendy02

こんばんは。Wendy02です。

>＞メモ帳などのテキストエディタで、以下のような内容のファイルを作り　拡張子を「.bat」にして>保存します。
>md "TestA"
>md "TestB"
>md "TestC

まあ、このレベルで出来ることは、WSH ではもっと効率よく出来るわけですが、本当は、欲を言えば、VB6 辺りか、Excelの　UserForm のTreeView という特別な機能を使って行うと、もっと便利になると思います。ただし、そういうことは、私自身、1・2度しか行ったことがないので、たぶん、こちらも四苦八苦してしまいます。こんなところで満足していただけるのなら、私としても幸いです。

お礼

漠然と岸壁を見上げていた時 手を伸ばせば掴める突起を指し示された感じです。ありがとうございました。いまさら老脳に鞭打てるか？の思いもありますが、知らない言葉=WSH を検索かけたら
http://homepage2.nifty.com/pasocon/nyumon/main.html
が目に留まりました。
季節労働の 超高周波の微細半田付け作業・撮影・整理 が終わる来春ですが、憧れの世界を探索してみようと思いました-----Windows3.1の頃入門したのに ソフトではなくハード（自作機）に走ってしまった"後悔"が再燃、決心だけは簡単と揶揄する自責も感じつつ。

＞　http://oshiete1.goo.ne.jp/kotaeru.php3?q=2376398​
を覗きました。やはり実メモリではなく、Windowsの欠点=狭苦しい "リーソース" でしたね。次期Windowsで増えるでしょうか。
昨年暮れ久しぶりに自作したASUSのマザーA8N32-SLI DELUXE にしたら、[休止状態]突入に時たま失敗するようになりました。特にPhotoshopを開いたまま旧マシンの時出来た[休止状態]が失敗するようになりました。Photoshopを閉じフリーソフトの『メモリの掃除屋さん』を手動で実行すると、成功率が上がりますが-----。
私の環境は左に立てたタスクバーにアイコンごっそりで　
起動時消費実メモリ600MB～700MB以上で この時　『メモリの掃除屋さん』を手動で数回実行すると　消費実メモリは300MB以下になりますが、リソースとの関係も少しは改善される感じです。怪しいですが。
http://www.vector.co.jp/soft/win95/hardware/se190988.html
------またまた脱線 カキコしてしまいました。お邪魔しました。そして
重ね重ねのご対応 心より感謝申し上げます。
ありがとうございました。

回答No.6

Wendy02

こんにちは。

ここの部分、ちょっと確認させてください。

>（ここまでは出来ますが　その4個の下夫々に6個、4個、3個のファイルを作ろうとして判らなくなってしまいました。）

何か複雑なので、間違っていると大変なことになりそうです。

（[デスクトップ]\CD\（001から050のファイルを作り）\4個のファイル\ )　×50個

>ここまでは出来ますが　
そうですね。それは分かります。

その次には、

ちょっと図がずれていたらすみません。

「4個の下それぞれ」という非対称のものなのですか？

---A--+あ
　 　　　+い
　 　　　+う
　 　　　+え
　 　　　+お
　 　　　+か

--- B--+き
　 　　　 +く
　 　　　 +け
　 　　　 +こ

----C--+さ
　 　　　 +し
　 　　　 +す
----D

いずれにしても、物理的に可能なものは、どんなフォルダにでも出来ます。それだけは確かです。

補足

ありがとうございます。間違えましたごめんなさい。
4個ではなく 3個の下に夫々--でした。
A B C にご推察どおりに（あ～す）がぶら下がります。

思いつきですが、
ExcelのA1＝A　A2＝B　A3＝C　のフォルダ名の時　
ぶる下がるフォルダを
G１～P１（あいうえおか）
G２～J２（きくけこ）
G３～I３（さしす）
とするのも良いかも？　改造しやすいので。

回答No.5

Wendy02

こんばんは。

Excelのメモリの話は、以下で私にとっての影響保存版のつもりで書きましたので、少し分かりにくいのですが、よかったらお読みください。（まだ、これから、それを元に、しばらくは手を加えてはいきます。)

# Excelの場合、ある意味では、結果論です。からです。

http://oshiete1.goo.ne.jp/kotaeru.php3?q=2376398
(　http://okwave.jp/kotaeru.php3?q=2376398　)

何かの参考になれば幸いです。もう、数年、この持論は通していますが、まあ、矛盾は生じていないようです。

>多量にあるxx.basを一個一個インポートするの大変で。『一括インポート無いの？ 』の空振り質問したほどでした。

これは、作ったことがあります。どちらかというと、禁じ手に近い部類の内容です。

＞お蔭様で大変心地よい日々が永続しそうです。
＞ありがとうございました。心底より感謝申し上げます。
こちらこそ! 私も、こうやって書きながら、勉強させていただいております。

お礼

重ねての暖かいご介助に涙ぐんでおります。
参考URLありがとうございました。後ほどうかがってみます。
今、もう数時間、苦悩しております。出来ればアドバイス戴けると助かります。
CreateDir2()でA列に入れるファイル名をどこかの親フォルダ参照または ぶら下がりサブフォルダ付きで処理実行できないでしょうか？
今現状は、50個以上のファイルを扱うことになり、Set NewSubFolders = Range("A1", Range("A90").End(xlUp))にしまして、
デスクトップのフォルダ\CD\（001から050のファイルを作り）\（A列指定の4個のファイルを50個にぶら下げる（ここまでは出来ますが　その4個の下夫々に6個、4個、3個のファイルを作ろうとして判らなくなってしまいました。）とりあえず001を完成させて
explorerでコピー＆ペーストを49回繰り返すしかありませんか？
変な要求ばかりで　ごめんなさい。

回答No.4

Wendy02

こんにちは。Wendy02です。

一つだけ、
>PERSONAL.XLSの標準モジュールにあります。

常に使う場合は、「PERSONAL.XLSの標準モジュール」でよろしいかと思いますが、そうでない場合は、個別のブックの標準モジュールでよいです。

「目的のサブフォルダがない場合、フォルダを作る」

フォルダの中のサブフォルダを作成する場合に、A列にあるサブフォルダ名が、そのフォルダ内にない場合は、サブフォルダを作るが正確な意味です。

>メモリを食うと言うことですが、たしか開放（全ての構文を削除）してインポートし直せば良いと読んだことがあります。

私は知りません。スクリプト型のマクロの場合は、スクリプトしていること自体が、アプリケーション側の監視状態に置かれますから、削除してインポートしても、入れればまた同じことです。メモリを使うのは、フォルダの抜き差しに対してで、Excelの使用可能メモリについてではありません。しかし、どの程度の割合なのか、予想しているわけではありません。極端なことをしなければ問題ないはずです。

お礼

ありがとうございます。早とちりしたようでお詫びいたします。＜サブフォルダがない場合作る＞ の意味理解しました。　　すでに実験では、サブフォルダの一部を削除し再実行してみるとエラーなくスンナリ補完されているので スゴイ と感動しておりました。
メモリの件は昔雑誌に書かれていたので、以前は信じてインポートし直していました。
多量にあるxx.basを一個一個インポートするの大変で。『一括インポート無いの？ 』の空振り質問したほどでした。＞Excelの場合、異様にメモリを消費するようです。　に反応して 書いてしまいました。　
実メモリは２ギガです。サブフォルダに保存するファイルは 細部閲覧用のA3ノビ600dpiでスキャンした馬鹿でかい画像です。これを角度を修正して切り抜き、個別画像にし保存します。
＞出来れば、標準モジュールが良い　　だったので 他の 教わったBVA群と同じ [PERSONAL.XLSの標準モジュール] にしましたが、使い勝手の都合で今は [フォルダ操作.xls] にしています。これを開くとシート別に [フォルダ製作][サブフォルダバッチ][フォルダ名変更][フォルダ名呼び込み]　となってます。

お蔭様で大変心地よい日々が永続しそうです。
ありがとうございました。心底より感謝申し上げます。

回答No.3

Wendy02

こんばんは。Wendy02です。
お話は分かりました。

フォルダ製作用マクロの修正と削除用マクロを作りました。

ただ、あまり実験的に何度も繰り返さないほうがよいと思います。Excelの場合、異様にメモリを消費するようです。ただし、最低限のエラー検知をするようには出来ています。また、ご存知だと思いますが、フォルダ削除の場合は、RmDir は、そのフォルダに何かファイルが入っていると削除しません。
その場合は、E列にエラーしたフォルダ名を出力するようになっています。

また、フォルダの生成・削除の確認は、一旦、エクスプローラを閉じないと、更新されないようです。

仕様：
CreateDir2

A列に生成するフォルダ名を列挙

DeleteDir2

D列に削除するフォルダ名を列挙
E列は、削除できなかったフォルダを列挙

両方とも、列挙数の上限は、現在は30個になっています。

'--------------------------------------------------
Sub CreateDir2()
'WriteDir2 と共に使用する
'サブフォルダを作るマクロ
Dim i As Integer
Dim j As Integer
Dim NewSubFolders As Range
'----------------------------------------
'A1からA30までに空白セルなしに入れる
Set NewSubFolders = Range("A1", Range("A30").End(xlUp))
'----------------------------------------
'B列に対して行う
For i = 1 To Range("B65536").End(xlUp).Row
　If InStr(Cells(i, 2).Value, "\") = 0 Then MsgBox "データが不自然です。", vbInformation: Exit Sub
　 For j = 1 To NewSubFolders.Rows.Count
　　 '目的のサブフォルダがない場合、フォルダを作る
　　 If Dir(Cells(i, 2).Value & "\" & NewSubFolders(j, 1).Value, vbDirectory) = "" Then
　　　 MkDir Cells(i, 2).Value & "\" & NewSubFolders(j, 1).Value
　　 End If
　 Next j
Next i
Set NewSubFolders = Nothing
End Sub

'--------------------------------------------------------

Sub DeleteDir2()
　'WriteDir2 と共に使用する
　'サブフォルダを削除するマクロ
　Dim i As Integer
　Dim j As Integer
　Dim k As Integer
　Dim DelSubFolders As Range
　'----------------------------------------
　'D1からD30までに空白セルなしに入れる
　Set DelSubFolders = Range("D1", Range("D30").End(xlUp))
　'----------------------------------------
　'B列に対して行う
　On Error Resume Next
　For i = 1 To Range("B65536").End(xlUp).Row
　　For j = 1 To DelSubFolders.Rows.Count
　　　'目的のサブフォルダがない場合、フォルダを作る
　　　If Dir(Cells(i, 2).Value & "\" & DelSubFolders(j, 1).Value, vbDirectory) <> "" Then
　　　　RmDir Cells(i, 2).Value & "\" & DelSubFolders(j, 1).Value
　　　　'失敗の場合(E列に書き出し)
　　　　If Dir(Cells(i, 2).Value & "\" & DelSubFolders(j, 1).Value, vbDirectory) <> "" Then
　　　　　　k = k + 1
　　　　　 Cells(k, 5).Value = Cells(i, 2).Value & "\" & DelSubFolders(j, 1).Value
　　　　End If
　　　End If
　　Next j
　Next i
　If Err.Number = 75 Then
　　MsgBox "サブフォルダにデータが残っています。", vbInformation
　ElseIf Err.Number > 0 Then
　　MsgBox Err.Number & ":" & Err.Description, vbCritical
　End If
On Error GoTo 0
　Set DelSubFolders = Nothing
End Sub

お礼

勘違いもあり 時間がかかりましたが出来ました。ありがとうございました。
私の場合　explorerを開いたままでもサブホルダの製作や削除は目視できました。
：ご回答Ano3の「'WriteDir2 と共に使用する」を推察して　Ano2の Sub WriteDir2() 以下をコピーし、その下にAno3の Sub CreateDir2() 以下をコピーしそれを PERSONAL.XLSの標準モジュールにあります。Excelを開いてマクロの実行をし登録したマクロの中からまずWriteDir2を実行してからCreateDir2やDeleteDir2を実行する と理解するまで何度も実験してしまいました。　メモリを食うと言うことですが、たしか開放（全ての構文を削除）してインポートし直せば良いと読んだことがあります。
[CreateDir2()]でExcelのA列に何も無いと実行しても何も起きません。構文にある「目的のサブフォルダがない場合、フォルダを作る」は表示されないですが、A列には当然記入してますからこれで良いと思います。または私のドジかも。　　
C:\a\(A列のホルダ名) で実行して成功したので　
こんどはA列をD列にコピーして[DeleteDir2()]を実行すると出来たばかりのホルダが削除されます。感動でした。そしてうれしかったです。
ありがとうございました。心より感謝申し上げます。

回答No.2

Wendy02

こんにちは。Wend02です。

もしかしたら、仮想フォルダで、他から取得できないような気がします。そうでなければよいのですが。
それと、Photoshpファイルは、"Adobe Photoshop Album" では管理出来ないのでしょうか？

一応、マクロは以下に掲示しました。なるべく、トラブルを避けるために、下位フォルダでおつくりください。

フォルダ取得用のマクロとフォルダ生成用のマクロ両方を作り直しました。WriteDir2 で、セルに書き出し、その内容を確認してから、CreateDir2 で実際のフォルダを作ってください。

現状では、
CreteDir2 のマクロでは、

Const NEWSUBFOLDER As String = "朝,昼,晩"
となっていますので、スペースの入らないようにして、コンマ「,」で区切って、設定してください。

フォルダがあれば、
A
B
C

A --+ 朝
　　|-昼
　　|-晩

B --+ 朝
　　|-昼
　　|-晩

C --+ 朝
　　|-昼
　　|-晩

となります。

'出来れば、標準モジュールが良い
'----------------------------------------
Sub WriteDir2()
'サブディレクトリ・書き出し用
　Dim objPath As Object
　Dim objSubFld As Object
　Dim myPath As String
　Dim i As Integer
　Dim fld As Variant
　'B列のチェック
　If Range("B1", Range("B65536").End(xlUp)).Count > 1 Then
　　If MsgBox("B列のデータを削除します。よろしいですか？", vbOKCancel) = vbCancel Then
　　　Exit Sub
　　Else
　　　Range("B1", Range("B65536").End(xlUp)).ClearContents
　　End If
　End If
　Set objPath = CreateObject("Shell.Application"). _
　BrowseForFolder(0, "フォルダを選択してください", &H0, "C:\")
　If Not objPath Is Nothing Then
　　myPath = objPath.Items.Item.Path
　Else
　　Exit Sub
　End If

　Set objSubFld = CreateObject("Scripting.FileSystemObject").GetFolder(myPath).SubFolders
　Application.ScreenUpdating = False
　For Each fld In objSubFld
　 i = i + 1
　 Cells(i, 2).Value = fld.Path
　 a = fld.Name
　Next fld
　Application.ScreenUpdating = True
　Set objPath = Nothing
　Set objSubFld = Nothing
End Sub
'-------------------------------------------------
Sub CreateDir2()
'WriteDir2 と共に使用する
'サブフォルダを作るマクロ
Dim i As Integer
Dim j As Integer
Dim FPath As String
Dim arDir As Variant
'----------------------------------------
'ここで、コンマ区切りで設定してください。（空白値は入れないでください)
Const NEWSUBFOLDER As String = "朝,昼,晩"
'----------------------------------------
arDir = Split(NEWSUBFOLDER, ",")
'B列に対して行う
For i = 1 To Range("B65536").End(xlUp).Row
　 For j = LBound(arDir) To UBound(arDir)
　 a = Cells(i, 2).Value
　　 '目的のサブフォルダがない場合、フォルダを作る
　　 If Dir(Cells(i, 2).Value & "\" & arDir(j), vbDirectory) = "" Then
　　　 MkDir Cells(i, 2).Value & "\" & arDir(j)
　　 End If
　 Next j
Next i
End Sub

'-------------------------------------------------

お礼

出来ました！　感謝　感謝です。
使ってみて、朝昼晩に相当するホルダ名をExcel上（例えばA列）から読み込めたら汎用性があるのですが。
さらに指定された（Excel上のD列などに表記された）不要ホルダを削除できると便利だと思いました。
実験中使用した朝昼晩が、１２個の決定ホルダ名と、共存しており削除方法を思案中です。

回答No.1

Wendy02

こんにちは。

ご質問のコードの内容には食い違いがあります。

>「朝」「昼」「晩」と ホルダーが3個作れるのを教わりましたが、

単に、サブフォルダ名を取るだけです。

>C:\イからロハニ.....と十数個のディレクトリ
その下に、本当に、サブフォルダを「朝」「昼」「晩」を作る（掘る)つもりなのですか？

私個人が躊躇してもしょうがないことですが、何か納得できないです。サブフォルダを親フォルダに対していくつか掘ったところで、実質的な影響は受けないけれども、単独でそのようなコードを用いても、意味がありません。あまり、何も考えずに、こちらもコードを提供するというわけにはいかないのです。

きちんとした、その目的を教えてくださいますか？

補足

ありがとうございました。間違えましたごめんなさい。誤採用はexplorerのホルダ名をエクセルに呼び込む構文でした。
訂正 ホルダ製作
Sub CrtDir()
Dim i, FPath
i = 1
Do While Cells(i, 2) <> ""
If Cells(i, 1) <> "" Then FPath = Cells(i, 1).Value
MkDir FPath & Cells(i, 2).Value
i = i + 1
Loop
End Sub

目的は、提出写真の形式設定でツリー状にホルダを作っておき、写真を振り分ける予定です。都道府県の下に市区町村がぶらさがり任意のバス停の朝昼晩の写真とでも考えてください。これを毎年春夏秋冬繰り返すとしたらホルダが出来ていたら便利かと考えたわけです。実際には製造過程写真ですが。
写真の状態はPhotoshopファイルで
都道府県に入れるべきもの　T001から10
市区町村に入れるべきもの　S001から20
バス停に入れるべきもの　　B001から30　までの通し番号となっています。これをjpgファイルにして目的の場所に保存しようと考えました。Photoshopのバッチ処理を必要に迫られ体験的に（保存先ホルダがある状態で）覚えましたもので。