フォルダ内のxlsをシートごとに別ファイルにしたい。

質問

現在開いているブックのシートごとにブックにするマクロはあったのですが
フォルダ内のブックを一気にばらすことはできませんか？
---元---
./甲.xls(シートa,シートb,シートc)
./乙.xls(シートa)
./丙.xls(シートa,シートb)
---元---
---先---
./甲a.xls(シートa)
./甲b.xls(シートb)
./甲c.xls(シートc)
./乙.xls(シートa)
./丙a.xls(シートa)
./丙b.xls(シートb)
※シート名もしくはseqをつけて分割
---先---
まとめてPDFを作ろうかとしたら複数シートがうまく行かないので
１ブック１シートの形式にできればと思ってます。
（通常時は複数シートがいいので１ファイルづつ作業は考慮したくない）

できましたらお願いいたします。

回答No.2

imogasi · ベストアンサー

多分VBA類を使わないと実現できないでしょう。質問者はどれぐらいVBAの勉強をしたかわからないが、多分荷が重過ぎると思う。
基本的にはFor Eachの２重ループになると思う。
それにエクセルVBAのほかに、VBScriptを使うことになると思う。回答者に完成品を作ってくださいというレベルだろう。
参考までにカレントパスに問題の（エクセル）ファイルがあるとして、エクセルファイルばかりで、その全ファイルかつ全シート名を捉えるコードをやってみた。結構試行錯誤の結果です。
残るは下記のMsgBox sh.Nameのところに、現に捉えている１シートの内容を新規１ブックとして保存するコードを考えて追加してください。
とりあえず下記を実行してみて、あとを考えてください。
標準モジュールに
Sub test01()
Dim objfile As Object
Dim sh As Object
cd = CurDir
Set objfs = CreateObject("scripting.filesystemobject")
Set objfolder = objfs.Getfolder(cd & "\")
Set app = CreateObject("Excel.Application")
For Each objfile In objfolder.Files
'MsgBox objfile.Drive
MsgBox objfile.Path
'MsgBox objfile.Name
Set wb = app.Workbooks.Open(objfile.Path)
For Each sh In wb.Worksheets
MsgBox sh.Name
Next
wb.Close
Set wb = Nothing
Next
Set app = Nothing
End Sub

お礼

ＶＢＡの勉強はしてません。画面操作もよく分からない状態で３，４時間試行錯誤しておりました。
ActiveSheetの切り替え等サッパリ分からない状態で

上記内容を元にMsgBox sh.Name　のタイミングでファイル名、シート名、保存したいファイル名をセルに入れてしまい
再度ブックを開きながら対象外シートを削除し保存のループ組んで
どうにか出来上がりました。

非常に参考になりました。ありがとうございます。

回答No.1

okormazd

>現在開いているブックのシートごとにブックにするマクロはあったのですが

フォルダに.xlsブックがいくつあるか知らないが、適当な数読込んで、

for each w in workbooks
対象でないブックは除いて
現在開いているブックのシートごとにブックにするマクロ
next

でできる。

お礼

別のブックを開いたときにそちらに制御を移すのがどうも分かりませんでした(^^;
どうにか解決いたしました。ありがとうございます。