Ｅｘｃｅｌ マクロで複数ブックのデータを一つのブックにまとめる方法

マクロ初心者です。
1つのフォルダの中に複数のbook（sheetも複数）があります。
これを新しい1つのbookにまとめたいです。
sheetは「bookを開いた時に表示されるsheetだけ」を新しいbookにまとめたいです。

どなたかの回答に下記マクロがありました。

Sub consolid()
Application.ScreenUpdating = False '画面更新を一時停止
Set mb = ThisWorkbook 'このコピー先ブックをmbとする。
myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索
Do Until fname = Empty '全て検索
If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ
Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。
wb.Worksheets.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く
wb.Close '開いたブックを閉じる
n = n + 1 'ブック数をカウント
End If
fname = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す
Application.ScreenUpdating = True '画面更新一時停止を解除
MsgBox n & "件のブックをコピーしましました。"
End Sub


非常によかったのですが、これですと
(1)全てのsheetがコピーされてしまいます。
(2)また、保存しますか？とbookごとに聞いてきます。

上記のマクロのどこを変更すれば、(1)(2)を解決できますでしょうか？
（エクセルは2002です）

以上、よろしくお願いします。

No.1 回答者： merlionXX 回答日時： 2008/02/07 11:39

どこかで見たような・・・と思ったら、わたしが書いたコードじゃないですか。

http://okwave.jp/qa2198774.html　ですね。

では、開いたBOOKのアクティブなシートだけをコピーします。
保存を聞かず、保存しないで開いたBOOKを閉じます。

Sub consolid()
Application.ScreenUpdating = False '画面更新を一時停止
Set mb = ThisWorkbook 'このコピー先ブックをmbとする。
myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索
Do Until fname = Empty '全て検索
If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ
Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。
wb.ActiveSheet.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く
wb.Close (False) '保存の有無を聞かずに保存しないで閉じる
n = n + 1 'ブック数をカウント
End If
fname = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す
Application.ScreenUpdating = True '画面更新一時停止を解除
MsgBox n & "件のブックをコピーしましました。"
End Sub

この回答への補足

す・すごい！
できました！ありがとうございました。

ただ1つだけ・・・
sheetとsheetの間のリンク貼付をしていた部分が、そのままbook間のリンクになってしまいます。
マクロで同時にリンクの解除というのは難しいのでしょうか？

ｐｓ
元々merlionXXさんが作られたマクロなのですね。
非常に親切で使いやすいですね。

補足日時：2008/02/07 12:32

No.2 回答者： suz83238 回答日時： 2008/02/07 11:44

sheetは「bookを開いた時に表示されるsheetだけ」→これはVBAで分からない。

シートの名前とかセルのどこに何が書いてあるシートとかの分岐ができなければ全部読むしかありません。
たとえば、ブック毎にシートが違うとすれば、それをブックとシート名のデータをあらかじめ作っておき、それを読んで作ることはできます。

>保存しますか？とbookごとに聞いてきます
これは、Application.ScreenUpdating = Falseの下にApplication.DisplayAlerts = False
を入れればOKです。
下のApplication.ScreenUpdating = True
Application.DisplayAlerts = True
を入れることを忘れずに。

No.3 回答者： merlionXX 回答日時： 2008/02/07 13:17

では、コピーされたシートにある式はすべて値に変えてみました。

Sub Consolid02()
Dim mb As Workbook, wb As Workbook
Dim myfdr As String, fname As String, n As Integer
Application.ScreenUpdating = False '画面更新を一時停止
Set mb = ThisWorkbook 'このコピー先ブックをmbとする。
myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索
Do Until fname = Empty '全て検索
If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ
Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。
wb.ActiveSheet.Copy After:=mb.Sheets(mb.Sheets.Count) '開いたシートをコピーしてmbの末尾に置く
wb.Close (False) '有無を言わずに保存せず閉じる
mb.Sheets(mb.Sheets.Count).Cells.Copy '取り込んだシートをコピー
mb.Sheets(mb.Sheets.Count).Cells.PasteSpecial Paste:=xlValues 'そのまま値で貼り付け（式を消す）
Application.CutCopyMode = False
n = n + 1 'ブック数をカウント
End If
fname = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す
Application.ScreenUpdating = True '画面更新一時停止を解除
MsgBox UCase(Environ("UserName")) & "さん、" & n & "件のブックをコピーしましました。" _
+ Chr(&HD) + Chr(&HA) + "式は消して値にしておきましたよ。", , "(〃^∇^)o"
End Sub

この回答への補足

さっそくのご回答ありがとうございます。

ですが・・・すいません。。
リンクしていない式が消えてしまうのは困ります。。。
また、複数人に配布するエクセルですので、シートの保護をかけようと思っています。
参照先がbook内の式だけはそのままで、リンクの式だけを消す　あるいは　編集→リンクの設定→リンクの解除　のようなことはできないでしょうか？
何度も何度も申しわけありません。。。

補足日時：2008/02/07 14:11

No.4 ベストアンサー 回答者： merlionXX 回答日時： 2008/02/07 15:14

やれやれ、注文が多いですねえ（笑）

では、他のシートを参照している式は値に、同一シート内のみを参照する式は残します。但し、他シート参照の有無は式に”!”を含むかどうかで判定しますので、「名前定義」された他シートのセル参照の場合はそれが他シートなのか同じシートなのか判定できないので残ってしまいます。

Sub Consolid03()
Dim mb As Workbook, wb As Workbook
Dim myfdr As String, fname As String, n As Integer
Application.ScreenUpdating = False '画面更新を一時停止
Set mb = ThisWorkbook 'このコピー先ブックをmbとする。
myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索
Do Until fname = Empty '全て検索
If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ
Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。
wb.ActiveSheet.Copy After:=mb.Sheets(mb.Sheets.Count) '開いたシートをコピーしてmbの末尾に置く
wb.Close (False) '有無を言わずに保存せず閉じる
For Each c In mb.Sheets(mb.Sheets.Count).UsedRange '取り込んだシートの使用範囲に
If c.FormulaR1C1 Like "=*!*" Then '他シート参照があれば
c.Value = c.Value '値に変更
End If
Next
mb.Sheets(mb.Sheets.Count).Protect Password:="merlionXX" 'パスワード保護
n = n + 1 'ブック数をカウント
End If
fname = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す
Application.ScreenUpdating = True '画面更新一時停止を解除
MsgBox "わがままな " & UCase(Environ("UserName")) & "さん、" & n & "件のブックをコピーしましました。" _
+ Chr(&HD) + Chr(&HA) + "他シートを参照する式だけは値にしておきましたよ。" _
+ Chr(&HD) + Chr(&HA) + "" _
+ Chr(&HD) + Chr(&HA) + "取りこんだシートにパスワード保護もかけておきましたよ。", , "（￣ー￣）v "
End Sub

この回答へのお礼

できました！
完璧です！
ありがとうございました。
また、何度も何度もすいませんでした。

お礼日時：2008/02/07 15:30