プロが教える店舗&オフィスのセキュリティ対策術

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

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

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

A 回答 (2件)

'同じBookの選択されたシートが対象


'シートの並び順で全部または一部データを「Summary」シートに集約
'出力=「Summary」シートは先頭に置く
'「xCopyRows」にコピーする行数を指定、0は全体
'データの最終行は「列:A」、最終列は「行:1」で決める
'「xHead」にヘッダの行数を指定、0以外はヘッダあり、0はヘッダなし
'ヘッダは対象の先頭シートからコピーする

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

この回答への補足

ゴメンナサイ(>_<)

私の勘違いで、
最初に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シートのデータを削除したいです。

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

補足日時:2012/10/17 11:33
    • good
    • 0
この回答へのお礼

ありがとうございます!
一番最初に貼り付けられるのですね。新しいシートが作られるのかと思ったのですが、それはそれで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




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


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

よろしくお願いします。

お礼日時:2012/10/17 11:00

『まとめる』って何?



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

この回答への補足

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

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

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

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

補足日時:2012/10/16 16:27
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!