複数ブックにあるシートを１つのブック束ねるマクロを汎用的に改良したい

質問

【質問編です。回答＃１に、元コードを掲示いたいます】

以下は、1つの新規ブックに、特定フォルダにある不特定多数の
ブックのSheet1を次々と束ねるマクロで、別の掲示板で教わりました。
よく使うので、大幅に汎用性をもたせたいのです。

(要望1) 束ねた際に、シート名をブック名にセットしたい。
（例：C:\temp\に、Book1.xls、Book2.xls、Book3.xls　とあったら、
　束ねられたシート名はBook1、Book2、Book3をシート名）

(要望2)CSVやTXTを束ねる場合、8行目のxlsをcsvに書き換えなければ
ならないので、ここは、その都度ダイアログで聞いて欲しい。
（規定値にxlsが入力されたInputBoxとか、XLS、CSVを選択させるラジオボタン等。）

(要望3)7行目の代わりに↓のような「フォルダの参照」ダイアログを表示し、
毎回7行目を書き換えないで済むようにしたい。
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_120.html

その他、このような仕様ならより汎用性が高いだろうと思われるもので
多機能化いただくのはとってもうれしいです。

どうぞ、よろしくお願い致します。

回答No.2

papparapar · ベストアンサー

現実的にはかなり無理があると思いますよ。どうしてもやりたいならば、
fname = Dir(dirname + "*.xls")
　If fname <> "" Then
　　Do While fname <> ""

　　～

　　Loop
fname = Dir(dirname + "*.csv")
　　Do While fname <> ""

　　～

　　Loop
と二つに分けて記述する方法ですね。
もしくは、
fname = Dir(dirname + "*.*")
　If fname <> "" Then
　　Do While fname <> ""
　　if right(fname,3) = "xls" then
　　～
　　elseif right(fname,3) = "csv" then
　　～

　　Loop
と言う記述ではどうでしょう？ですが、csvファイルはスペース区切りだったりカンマ区切りだったり項目数も一様ではないと思われますので実用的にはどうでしょうか？

お礼

papparaparさん、御礼遅くなってすみません。

＞csvファイルはスペース区切りだったりカンマ区切りだったり
＞項目数も一様ではないと思われますので実用的にはどうでしょうか？

とのことですが、
＃１のサンプルに示した8行目のxlsをcsvに書き換えるだけで、
CSVでも取り込んでいけるのですが。
（拡張子がCSVでExcelに関連付けられており、Excelで開いてから
束ねているのがよいのでしょうか？）

ともあれ、いただいた二つの記述を参考にさせていただきます。
ありがとうございました。

回答No.3

imogasi

＞要望2)CSVやTXTを束ねる場合、8行目のxlsをcsvに書き換えなければ
ならないので、ここは、その都度ダイアログで聞いて欲しい。
拡張子を捕まえる事はもちろん必要です。しかし、それは大幅なロジックの違う、ルーチンへ枝分かれする、条件で、ほぼ共通しているものの、１部が変わる条件と考えているならば、勉強が必要でしょう。
何か勘違いしてないか心配です。拡張子もふくめたファイル名の指定は絶対必要ですが。
ーー
言っていることは、＃２のご指摘の趣旨と似ていて、ＴＸＴとＣＳＶは扱いが相当変わるはずで、その辺は認識しているのでしょうか。
ことを急ぎすぎている気がする。
（１）ＴＸＴファイルをエクセルに読み込む。
（２）ＣＳＶファイルをエクセルに読み込む。
（３）他ブックのシートを読んで、当シートの終わりに追加
（４）シート名のセットは
Sub test01()
Worksheets("Sheet1").Name = "AAA"
End Sub
のように簡単。
（５）同一ブック内の各シートデータは、１シートに集めるのですか。元のシートのままですか。この点が不明確。
（６）与件を文章で整理する技術が大切。改造をしたいしたいが先走らず、整理されたしたいことを示して、回答を募るべきです。
本件はそうでもないが、回答者に長いコーディングを読ませて分析させるのもどうかと思う。

お礼

いろいろとお教えいただきありがとうございました。
お礼遅くなってすみません。

＞ＴＸＴとＣＳＶは扱いが相当変わるはずで、その辺は認識しているのでしょうか

できていないようです。
ご指摘のとおり、「改造をしたいしたいが先走」っていたようです。

もう少し勉強して出直します。いろいろとすみませんでした。

回答No.1

noname#185101

元質問者です。コードは下記の通りです。よろしくお願い致します。

Sub OpenFiles()
　Dim i As Integer
　Dim wb As Workbook
　Dim fname
　Dim dirname As String
　i = 1
　dirname = "C:\temp\"
　fname = Dir(dirname + "*.xls")
　If fname <> "" Then
　　Do While fname <> ""
　　　If fname <> "." And fname <> ".." Then
　　　　If i = 1 Then
　　　　　' 最初のファイルを開く
　　　　　Workbooks.OpenText FileName:=dirname + fname
　　　　　Set wb = ActiveWorkbook
　　　　　' 最初のファイルを新規ブックに複製して閉じる。
　　　　　ActiveSheet.Copy
　　　　　wb.Close
　　　　　Set wb = ActiveWorkbook
　　　　Else
　　　　　' 2番目以降のファイルは複製した最初のファイルに追加
　　　　　Workbooks.OpenText FileName:=dirname + fname
　　　　　ActiveSheet.Move After:=wb.Worksheets(wb.Worksheets.Count)
　　　　End If
　　　　i = i + 1
　　　End If
　　　fname = Dir
　　Loop
　Else
　　MsgBox "検索条件を満たすファイルはありません。"
　End If
　Set wb = Nothing
End Sub