複数シートの内容を1つのシートに集計するVBA

質問

お世話になります。

ExcelのVBAについて質問させていただきます。

集計.xlsというブックがあります。
この中に[集計]、[東京支店]、[名古屋支店]、[大阪支店]というシートがあります。

やりたい事は[東京支店]、[名古屋支店]、[大阪支店]のシート内容を[集計]シートに順番にコピペしていきたいのです。

下記のVBAを組んでみましたがうまくいきません。

[東京支店]はうまくコピペ出来ますが、[名古屋支店]がコピペされず、[大阪支店]はコピペされますが東京支店のデータのすぐ下ではなく、50行ぐらい下の位置にコピペされてしまいます。
各支店のシートの内容は次の通りです。この内容を[集計]シートにコピペしたいのです。

[日付]　[担当者]　[金額]
11/1 田中 100円
11/2 山田 500円

どなたかご教授いただけますでしょうか？

環境
Windows XP SP3
Excel2003

****VBA****

Sub test()

Dim 下 As Integer

'東京支店
Sheets("東京支店").Select
Range("A2").Select

'東京支店シートの見出し以外の全データをコピー
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

'集計シートに貼り付け
Sheets("集計").Select
Range("A2").Select
ActiveSheet.Paste

'次は名古屋支店
Sheets("名古屋支店").Select
Range("A2").Select

'名古屋支店シートの見出し以外の全データをコピー
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

'集計シートの最下行を取得
Sheets("集計").Select
下 = Range("A1").CurrentRegion.Rows.Count + 1

'集計シートに貼り付け
Range("A2").Select
ActiveCell.Offset(下 & "," & 0).Select
ActiveSheet.Paste

'最後に大阪支店
Sheets("大阪支店").Select
Range("A2").Select

'大阪支店シートの見出し以外の全データをコピー
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy

'集計シートの最下行を取得
Sheets("集計").Select
下 = Range("A1").CurrentRegion.Rows.Count + 1

'集計シートに貼り付け
Range("A2").Select
ActiveCell.Offset(下 & "," & 0).Select
ActiveSheet.Paste

End Sub

回答No.5

K Kazz（@JazzCorp） · ベストアンサー

訂正版：
範囲のコピーは難しいので行単位のコピーに変更。

「東京」分だけヘッダを出力
Selectを整理
セルのコピーは値だけにしたので、数式等含めたければオプションの「xlPasteValues」を削除する
最初に"集計"をクリアしたので、やり直しは何回でも可能！

Option Explicit
Sub SummarySheets()
Const xSummary = "集計" 'マージ出力先シート名
Const xBase = "A1" 'データ貼付けの基点
Const xHeads = 1 'ヘッダ行数
Dim xSheet As Worksheet
Dim zSheet As Worksheet
Dim xLast As Long
Dim zLast As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set xSheet = Worksheets(xSummary)
xSheet.UsedRange.Clear
'東京支店
Set zSheet = Worksheets("東京支店")
With zSheet
'東京支店シートの見出し以外の全データをコピー
zLast = zSheet.Cells(Rows.Count, "A").End(xlUp).Row
zSheet.Rows(1 & ":" & zLast).Copy
End With
xSheet.Range(xBase).PasteSpecial xlPasteValues
'次は名古屋支店
Set zSheet = Worksheets("名古屋支店")
With zSheet
'名古屋支店シートの見出し以外の全データをコピー
zLast = zSheet.Cells(Rows.Count, "A").End(xlUp).Row
zSheet.Rows((1 + xHeads) & ":" & zLast).Copy
End With
'集計シートの最下行を取得
xLast = xSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
xSheet.Cells(xLast, "A").PasteSpecial xlPasteValues
'最後に大阪支店
Set zSheet = Worksheets("大阪支店")
With zSheet
'大阪支店シートの見出し以外の全データをコピー
zLast = zSheet.Cells(Rows.Count, "A").End(xlUp).Row
zSheet.Rows((1 + xHeads) & ":" & zLast).Copy
End With
xLast = xSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
xSheet.Cells(xLast, "A").PasteSpecial xlPasteValues
xSheet.Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

お礼

JazzCorpさん、何度もご連絡ありがとうございます！

ご教授いただきましたやり方で実現できました！

本当にありがとうございました！！
大変勉強になりました(^^)

回答No.4

K Kazz（@JazzCorp）

「東京」分だけヘッダを出力
Selectを整理
セルのコピーは値だけにしたので、数式等含めたければオプションの「xlPasteValues」を削除する
最初に"集計"をクリアしたので、やり直しは何回でも可能！

Option Explicit
Sub SummarySheets()
Const xBase = "A1" 'データ貼付けの基点
Const xHeads = 1 'ヘッダ行数
Dim xSheet As Worksheet
Dim 下 As Integer

Set xSheet = Worksheets("集計")
xSheet.UsedRange.Clear
'東京支店
Sheets("東京支店").Select
'東京支店シートの見出し以外の全データをコピー
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
xSheet.Range(xBase).PasteSpecial xlPasteValues
'次は名古屋支店
Sheets("名古屋支店").Select
Cells(Range(xBase).Row + xHeads, Range(xBase).Column).Select
'名古屋支店シートの見出し以外の全データをコピー
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'集計シートの最下行を取得
'集計シートに貼り付け
下 = xSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
xSheet.Cells(下, "A").PasteSpecial xlPasteValues
'最後に大阪支店
Sheets("大阪支店").Select
Cells(Range(xBase).Row + xHeads, Range(xBase).Column).Select
'大阪支店シートの見出し以外の全データをコピー
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
'集計シートの最下行を取得
'集計シートに貼り付け
下 = xSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
xSheet.Cells(下, "A").PasteSpecial xlPasteValues
xSheet.Select
End Sub

回答No.3

K Kazz（@JazzCorp）

とりあえずこれを試してみては？
同じBOOKの全シートを順番にマージします。
'複数のシートを１枚にまとめる
Sub MergeAllSheets()
Const xTo = "集計"
Dim xData As Range
Dim xLast As Long
Dim kk As Long
Dim ans As Integer

Application.ScreenUpdating = False
Application.DisplayAlerts = False
ans = MsgBox("Are You Sure？(Final Answer？)", vbYesNo)
If (ans = vbNo) Then Exit Sub
For kk = 1 To Worksheets.Count
If (Worksheets(kk).Name = xTo) Then
Worksheets(kk).Delete
Exit For
End If
Next kk
Worksheets.Add before:=Worksheets(1)
Worksheets(1).Name = xTo
For kk = 2 To Worksheets.Count
Set xData = Worksheets(kk).UsedRange
xData.Copy
With Worksheets(xTo)
'(3) 転記先のシートのどの行までデータが入っているかを調べる
xLast = .Cells(Rows.Count, "A").End(xlUp).Row
If xLast = 1 Then
.Range("A" & xLast).PasteSpecial xlPasteValues
Else
.Range("A" & xLast + 1).PasteSpecial xlPasteValues
End If
End With
Next kk
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

補足

JazzCorpさん、早速のご連絡ありがとうございます！

お忙しい中、このような詳細なロジックをご教授いただきまして本当にありがとうございます！

現在業務中のため、後程試させていただきます！

この度はありがとうございました！

回答No.2

mt2008

大きな間違いは２つあります。
1つは、↓
ActiveCell.Offset(下 & "," & 0).Select

これですと、例えば変数「下」の値が5の時、「下 & "," & 0」は、"5,0"と言う文字列になります。Excelはこれを「50」と認識するようで、50行オフセットされてしまいます。
正しくは、↓このようにします。
ActiveCell.Offset(下, 0).Select

もう一つは変数「下」に値を代入している↓です。
下 = Range("A1").CurrentRegion.Rows.Count + 1

これは、セルA1から連続して値が入っているセル範囲の最後の行+1を返します。途中で空行があると、そこが最終行と認識されます。
名古屋支店のデータを貼り付けるときはこのままでも良いのですが、東京支店と名古屋支店のデータの間に空行を入れていますので、大阪支店のデータを貼り付けるときも、変数「下」には名古屋支店のデータを貼り付けるときと同じ値が入ります。
使用している最終行を求めるには↓の様にするとよいでしょう。
下 = Cells(Rows.Count, 1).End(xlUp).Row　+1

お礼

ｍｔ2008さん、ご教授いただきましたやり方で実現できました！
本当にありがとうございました！！

この度、色々な方から方法をご教授いただきました中でmt2008さんの方法でも実現可能な事を確認させていただきました。

本当にありがとうございました！！
大変勉強になりました(^^)

補足

mt2008pさん、早速のご連絡ありがとうございます！

お忙しい中このような詳細なロジックのご教授、並びに私のミスをご指摘いただきまして本当にありがとうございます！
大変勉強になりました。

現在業務中のため、後程試させていただきます！

この度はありがとうございました！

回答No.1

tom04

こんにちは！
一例です。

各Sheetとも1行目がタイトル行で2行目以降にデータがあるとします。
1行目の項目列は全Sheet同じとして・・・

標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub test()
Dim i As Long
Dim j As Long
Dim k As Long
Dim str As String
Dim myArray As Variant
Dim ws As Worksheet
Set ws = Worksheets("集計")
myArray = Array("東京支店", "名古屋支店", "大阪支店")

i = ws.Cells(Rows.Count, 1).End(xlUp).Row
j = ws.Cells(1, Columns.Count).End(xlToLeft).Column
If i > 1 Then
Range(ws.Cells(2, 1), ws.Cells(i, j)).ClearContents
End If

For k = 0 To UBound(myArray)
str = myArray(k)
i = Worksheets(str).Cells(Rows.Count, 1).End(xlUp).Row
Range(Worksheets(str).Cells(2, 1), Worksheets(str).Cells(i, j)).Copy _
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)
Next k
End Sub

こんな感じではどうでしょうか？m（_ _）m

お礼

tom04さん、ご教授いただきましたやり方で実現できました！
本当にありがとうございました！！

この度、色々な方から方法をご教授いただきました中でtom04さんの方法でも実現可能な事を確認させていただきました。

本当にありがとうございました！！
大変勉強になりました(^^)

補足

tom04さん、早速のご連絡ありがとうございます！

お忙しい中細かなロジックをご教授いただきまして本当にありがとうございます！私のロジックとは比べモノにならないキレイなロジックで見ているだけで大変勉強になります。

現在業務中のため、後程試させていただきます！

この度はありがとうございました！