EXCEL 選択したシートのデータをまとめるマクロ

質問

EXCEL2010で質問です。 シート１～１０まであったとします。 そのうち、シート３～５を選択しておいてマクロを実行すると、新しいシートにシート３～５のデータをまとめるマクロを教えて下さい。

ファイルの全てのシートをまとめるマクロを見付けたので何とかしようとしたのですが、全然歯が立たずで(>_<)

すみません。よろしくお願いいたします。

回答No.2

K Kazz（@JazzCorp）

'同じBookの選択されたシートが対象
'シートの並び順で全部または一部データを「Summary」シートに集約
'出力＝「Summary」シートは先頭に置く
'「xCopyRows」にコピーする行数を指定、０は全体
'データの最終行は「列：Ａ」、最終列は「行：１」で決める
'「xHead」にヘッダの行数を指定、０以外はヘッダあり、０はヘッダなし
'ヘッダは対象の先頭シートからコピーする

Sub Summary_SelectedSheetsActiveWindow()
Const xCopyRows = 0
Const xHead = 1
Const xNameSummary = "Summary" '先頭に置く
Dim xFirst As Boolean
Dim xSh As Worksheet
Dim xLast As Long, xRight As Long
Dim xLast_To As Long
Dim jj As Long
Dim kk As Long
Dim SheetObj As Object

Application.ScreenUpdating = False
Application.DisplayAlerts = False
xFirst = True
'複数シートのデータを「Summary」へコピー
For Each SheetObj In ActiveWindow.SelectedSheets
If (xHead <> 0) And (xFirst) Then
'列見出しをコピー
SheetObj.Range("1:" & xHead).Copy Worksheets(1).Range("A1")
xFirst = False
End If
If xCopyRows = 0 Then
xLast = SheetObj.Cells(Rows.Count, 1).End(xlUp).Row
Else
xLast = xCopyRows + xHead
End If
xRight = SheetObj.Cells(1, Columns.Count).End(xlToLeft).Column
'データをコピー
If xLast > xHead Then
xLast_To = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
If xLast_To > 1 Or xHead <> 0 Then
xLast_To = xLast_To + 1
End If
SheetObj.Range(SheetObj.Cells(1 + xHead, 1), SheetObj.Cells(xLast, xRight)).Copy
Worksheets(1).Cells(xLast_To, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'MsgBox (SheetObj.Cells(1 + xHead, 1))
End If
Next SheetObj

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます！
一番最初に貼り付けられるのですね。新しいシートが作られるのかと思ったのですが、それはそれでOKです。助かりました。

ソースを見ても今の自分には？？？でして・・・こんなに複雑だったのですね。ホントに助かりました。ありがとうございました。

ただ、実はファイルの中には

・各シートの1行目余計なデータ（集計行）があるシートがある

・K列L列にデータを使ってピボットが作られている

ものがあります。

この有無はファイル毎に決まっているので、最初に削除しようと思い、
教えて頂いたソースのDim SheetObj As Objectの後に

Dim SheetObj2 As Object

Dim bunki As Integer

bunki = MsgBox("KL列と1行目を削除しますか", vbYesNo)

Application.ScreenUpdating = False
Application.DisplayAlerts = False
xFirst = True

For Each SheetObj2 In ActiveWindow.SelectedSheets

'bunkiがyesなら削除
If bunki = vbYes Then
Range("k:l").Delete
Range("1:1").Delete
End If

Next SheetObj2

としたのですが、なぜか同じデータを何度か貼り付けてしまいます。
それ以外では問題ないのですが・・・

もしよろしければ、何か対策を教えて頂けないでしょうか？

よろしくお願いします。

補足

ゴメンナサイ(>_<)

私の勘違いで、
最初にSummaryシートを作成しなければならないのですね。

そうすると・・・

最初にSummaryシートを自動で作るコードを入れようとしたのですが、
Dim newSh As String
Dim Sh As Worksheet, myFlag As Boolean

　　newSh = "Summary"
　　myFlag = False
　　For Each Sh In ThisWorkbook.Worksheets
　　　　If Sh.Name = newSh Then
　　　　　　myFlag = True
　　　　　　Exit For
　　　　End If
　　Next Sh
　　If myFlag = False Then
　　　　ActiveWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = newSh
End If

としたのですが、選択しただけ枚数が出来るのと、アクティブシートが変わるためかデータの移行がうまくいかないのです。

あと、Summaryシートが存在する場合は、いったんSummaryシートのデータを削除したいです。

どうすれば良いでしょうか？よろしくお願いします。

回答No.1

trajaa

『まとめる』って何？

何をどのようにまとめるのかが明確でなければ、何も始まらない。

補足

ごめんなさい。説明が不十分でした。

それぞれのシートにあるデータをコピーして、新しいシートに貼り付けると言うつもりでした。

これで分かりますでしょうか？？？

よろしくお願いいたします。