複数ファイルにある特定のシートを１つにまとめたい

質問

エクセルで複数ファイルにある特定のシートの特定した範囲を
１つのファイルにまとめたいと思っています。
ネットで調べて見て、１つのワークシートしかない場合の
複数ファイルをまとめるマクロは探すことができました。
複数のシートから特定のシートの特定した範囲を１つにまとめる
場合はどこを変えたらいいのでしょうか？

Sub ブック集合()
Application.ScreenUpdating = False
FN$ = Dir("C:\My Documents\Test\*.xls", vbNormal)
i% = 1
Do Until FN$ = ""
Workbooks.Open FileName:="C:\My Documents\Test\" & FN$
With ActiveWorkbook
.Worksheets(1).Copy After:=ThisWorkbook.Worksheets(i%)
.Close SaveChanges:=False
End With
i% = i% + 1
FN$ = Dir()
Loop
ThisWorkbook.Worksheets(1).Delete
Application.ScreenUpdating = True
End Sub

回答No.6

ham_kamo · ベストアンサー

> 同じフォルダにあるファイルをコピーしたい場合は
> どのコードを直せばいいのでしょうか？

あれ、おかしいですね。このマクロは同じフォルダにある全ての*.xlsファイル（自分自身を除く）以外をコピーして、その他のフォルダのファイルはいじらないのですが。

> このままだと関係ないファイルまでコピーしようとして
> ＞Workbooks(FileName).Sheets("B").Range("A1:Z500").Copy
> の部分でエラーがでてしまうので・・・。

確認していただきたいのですが、Excelファイルは同じフォルダにコピーするブックと、まとめ用ブック以外にはありませんか？
（要は同じフォルダに「Ｂ」という名前のシートを持たないファイルがあると、上記の部分でエラーになるのですが、上のマクロはそういうファイルはないという前提なのです）

もし同じフォルダにあるはずの「Ｂシート」を転記する処理がぜんぜん行われてないとなると、強制的にフォルダの位置を指定する、

Chdir "C:\My Documents"

という行（フォルダ名は実際のフォルダ名に置きかえてください）を、

FileName = Dir("*.xls")

の直前に挿入してみてください。

お礼

ありがとうございます。
できました！
このような作業をする場面が多いのでとても助かりました。m(__)m

回答No.5

ham_kamo

値で貼り付けですね。するとこういう感じでどうでしょうか。

Sub ブック集合()
　　Dim FileName As String
　　Dim c As Integer
　　Dim OpenedBook As Workbook
　　Dim IsBookOpen As Boolean

　　FileName = Dir("*.xls")
　　Application.ScreenUpdating = False
　　Application.DisplayAlerts = False
　　c = 0
　　Do While FileName <> ""
　　　　If FileName <> ThisWorkbook.Name Then
　　　　　　IsBookOpen = False
　　　　　　For Each OpenedBook In Workbooks
　　　　　　　　If OpenedBook.Name = FileName Then
　　　　　　　　　　IsBookOpen = True
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next
　　　　　　If IsBookOpen = False Then
　　　　　　　　Workbooks.Open (FileName)
　　　　　　End If
　　　　　　Workbooks(FileName).Sheets("B").Range("A1:Z500").Copy
　　　　　　ThisWorkbook.Sheets(1).Cells(c * 500 + 1, 1).PasteSpecial (xlPasteValues)
　　　　　　c = c + 1
　　　　　　If IsBookOpen = False Then
　　　　　　　　Workbooks(FileName).Close
　　　　　　End If
　　　　End If
　　　　FileName = Dir()
　　Loop
　　Application.DisplayAlerts = True
　　Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。
助かりました。
最後に
同じフォルダにあるファイルをコピーしたい場合は
どのコードを直せばいいのでしょうか？

このままだと関係ないファイルまでコピーしようとして

＞Workbooks(FileName).Sheets("B").Range("A1:Z500").Copy
の部分でエラーがでてしまうので・・・。

申し訳ありません。

回答No.4

ham_kamo

No.3です。補足拝見しました。

> Ｂ（Ｂはみんな同じです）というワークシートのA1:Z500までの
> データを新規のブックの１つのワークシートにまとめたいのです。

の「まとめかた」がよくわからないです。「まとめる」というのは「集計する」ではなくて、１つのシートにコピーする、ということでしょうか？３つブックがあって、それぞれのシートＢのA1:Z500を、
ブック１→まとめシートのA1:Z500
ブック２→まとめシートのA501:Z1000
ブック３→まとめシートのA1001:Z1500
というように上から転記していけばいいのでしょうか？

とりあえず、昨日似たようなマクロを書いたところなので、それを手直ししてみました。
・まとめブックと同じフォルダ以外にある全ての*.xlsファイルを開き、シートBのA1:Z500をまとめブックの1枚目のシートに上からコピーしていきます。（１つめはA1:Z500にコピー、２つめはA501:Z1000にコピー．．．）
・開いたブックにＢという名前のシートがない場合、マクロがエラーになります。

Sub ブック集合()
　　Dim FileName As String
　　Dim c As Integer
　　Dim OpenedBook As Workbook
　　Dim IsBookOpen As Boolean

　　FileName = Dir("*.xls")
　　Application.ScreenUpdating = False
　　c = 0
　　Do While FileName <> ""
　　　　If FileName <> ThisWorkbook.Name Then
　　　　　　IsBookOpen = False
　　　　　　For Each OpenedBook In Workbooks
　　　　　　　　If OpenedBook.Name = FileName Then
　　　　　　　　　　IsBookOpen = True
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next
　　　　　　If IsBookOpen = False Then
　　　　　　　　Workbooks.Open (FileName)
　　　　　　End If
　　　　　　Workbooks(FileName).Sheets("B").Range("A1:Z500").Copy _
　　　　　　　　ThisWorkbook.Sheets(1).Cells(c * 500 + 1, 1)
　　　　　　c = c + 1
　　　　　　If IsBookOpen = False Then
　　　　　　　　Workbooks(FileName).Close
　　　　　　End If
　　　　End If
　　　　FileName = Dir()
　　Loop
　　Application.ScreenUpdating = True
End Sub

補足

ありがとうございます。
助かります。
まとめるとは１つのシートにコピーすることです。

しかし、できればまとめブックと同じフォルダにあるファイルの
シートBのA1:Z500をまとめブックの1枚目のシートに上からコピー
して値を貼り付けという風にしたいのですが・・。
すべて貼り付けにしてしまうとリンクまで張り付いてしまうので。

何度もお手数をおかけしてしまって申し訳ないです・・。

回答No.3

ham_kamo

えっと、これは複数のブックにある複数のシートから、特定のシートの特定した範囲を１つにまとめたい、ということですか？
具体的な条件（どのシートのどの範囲をどのようにまとめるか）がわからないと適切なアドバイスは難しいですが、上の場合だと、

.Worksheets(1).Copy After:=ThisWorkbook.Worksheets(i%)

の部分を、やりたい処理に書き換える必要があります。たとえば、
　　Dim s As Worksheet　
　　For Each s In .Worksheets
　　　　If sが特定のシート Then
　　　　　　sの特定の範囲を、まとめるブックのどこかのシートのどこかのセルコピー
　　　　End If
　　Next
みたいな処理が入るかと。

補足

早速の回答ありがとうございます。

上の場合だとシートのコピーになってしまうのですが
やりたいことはＡからＺまでのブックの
Ｂ（Ｂはみんな同じです）というワークシートのA1:Z500までの
データを新規のブックの１つのワークシートにまとめたいのです。
ブック名はそれぞれですが、シート名と範囲は一緒です。
はよくてその後は書き換えないといけないかなと・・・。
それがまったくわからないんです・・。

上の質問のマクロはテストで実行してみましたが
エラーが出てできませんでした・・。

再度探してこのマクロだと最後まで実行できました。
しかし、シートごとのコピーなのでやりたいこととは
違います・・。

Sub ブック集合()

Dim Wb As Workbook
Dim Fname As Variant
Dim i As Integer, j As Integer
j = ThisWorkbook.Sheets.Count
Fname = Application.GetOpenFilename("EXCELファイル(*.xls), *.xls", , , , True)
If Not IsArray(Fname) Then Exit Sub
Application.ScreenUpdating = False
For i = 1 To UBound(Fname)

Workbooks.Open (Fname(i))
Set Wb = ActiveWorkbook
With ThisWorkbook
Wb.Sheets(1).Copy , After:=.Sheets(.Sheets.Count)
End With
Wb.Close
Next
Application.DisplayAlerts = False
For i = 1 To j
ThisWorkbook.Sheets(i).Delete
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

回答No.2

Nouble

おっと！
シート全体ではなのですね

失礼しました　<(_　_)>

回答No.1

Nouble

マクロでないとだめなのですか?

保存先と移動元のブックを開いて
両ブック中でシート名の名前のダブりがないように調整して
移動元の移動させるシートのタブを右クリック
出てきたメニューの中から「移動またはコピー」を選択
出てきたウインドウの上方「移動先ブック名」のプルダウンから保存先ブック名を選択
その下方「保存先」より保存先ブック内でのシートの位置を選択
最下方「コピーを作成する」にチェックが入ってない状態のまま
「Ok」をクリックすると
シートが移動します

以上を必要数繰り返せばまとめられますが
これでは駄目ですか?