複数のエクセルブックをひとつのブックにまとめる方法

同一フォルダに複数のエクセルブック（100個以上）が入っています。
その中のSheet1だけ（Sheet1～3まですべてのブックにあります）を一つのエクセルにまとめたいです。

ブックの中にSheet1、Sheet1(1)、Sheet1(2)・・・
みたいになればいいです。

Sheet名がブック名になるのが理想ですが。。


どのようにすればよろしいでしょうか？

No.3 回答者： MSZ006 回答日時： 2013/09/13 15:49

＃２に補足です。

新規に作ったマクロ入りブックは、集計するブックたちと同一フォルダにいったん保存してから、再度開いてマクロを実行してください。

No.2 回答者： MSZ006 回答日時： 2013/09/13 14:46

こんなかんじでどうでしょうか。

新規にエクセルブックを作成してそのブックに以下のコードを入力してください。
マクロを実行すると各ブックのsheet1が集められます。シート名はブック名になります。
----------

Sub test()
Dim Fname As String
Dim Wbm As Workbook
Dim Wbs As Workbook

Application.ScreenUpdating = False

Set Wbs = ThisWorkbook
Fname = Dir(ThisWorkbook.Path & "\*.xls*")

Do While Fname <> ""
If Fname <> ThisWorkbook.Name Then
Workbooks.Open ThisWorkbook.Path & "\" & Fname
Set Wbm = ActiveWorkbook

Wbm.Worksheets("sheet1").Copy after:=Wbs.Worksheets(Wbs.Worksheets.Count)
ActiveSheet.Name = Left(Fname, InStr(Fname, ".") - 1)
Wbm.Close
End If
Fname = Dir()
Loop

Application.ScreenUpdating = True

End Sub

No.1 回答者： x-1919 回答日時： 2013/09/13 13:42

VBScript で作成してみました。

以下のコードをメモ帳で作成し、拡張子を vbs にして実行してください。
vbs ファイルの実行方法とかはご自分で探してください。



Option Explicit

' 統合したブックの保存名
Dim margedBookPath
margedBookPath = "D:\margedBook.xlsx"

' 対象ブック群が保存されているパス
Dim targetPath
targetPath = "D:\test"

' 対象ブックの拡張子
Dim targetExtension
targetExtension = "xlsx"

Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")

' 対象ブックが保存されているパスを参照
Dim targetFolder
Set targetFolder = fso.GetFolder(targetPath)

' Excel 起動
Dim xlApp
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True

' 統合ブックを新規作成
Dim margedBook
Set margedBook = xlApp.Workbooks.Add

' 統合ブックの初期シート数を記憶しておく
Dim initialSheetsCount
initialSheetsCount = margedBook.Worksheets.Count

Dim targetBook

' 対象ブックが保存されているフォルダー内の全てのファイルを精査
Dim f
For Each f In targetFolder.Files
Dim targetSheet ' 対象ブック内のコピー対象シート
Dim copiedSheet ' 統合ブック内のコピーされてきたシート

' ファイルの拡張子が合致すれば
If fso.GetExtensionName(f.Name) = targetExtension Then
' 対象ブックを開き、1枚目のシートを統合ブックにコピーする (右端にコピー)
Set targetBook = xlApp.Workbooks.Open(f.Path, 0, True)
Set targetSheet = targetBook.Worksheets(1)
Call targetSheet.Copy(, margedBook.Worksheets(margedBook.Worksheets.Count))

' コピーされたシートの名前を変更
Set copiedSheet = margedBook.Worksheets(margedBook.Worksheets.Count)
copiedSheet.Name = fso.GetBaseName(targetBook.Name)

' 対象ブックを閉じる
Set targetSheet = Nothing
call targetBook.Close(False)
Set targetBook = Nothing
End If
Next

xlApp.DisplayAlerts = False

' 統合ブックから初期シートを削除する (左端の数枚)
Dim i
For i = 1 To initialSheetsCount
margedBook.Worksheets(1).Delete
Next

' 統合ブックを保存して閉じる
Call margedBook.SaveAs(margedBookPath)
Call margedBook.Close(False)

xlApp.DisplayAlerts = True
xlApp.Quit
Set xlApp = Nothing