[[20131108144024]]　『複数シートのデータを一つのシートに集計する際、』（kenj）　ページの最後に飛ぶ

『複数シートのデータを一つのシートに集計する際、シート名を見出しにつけたい』（kenj）

Excelは2003です。

よろしくお願いします。

複数のシート(11月1日、11月2日、11月3日、11月4日)にそれぞれ
ID　名前　　値段　個数売上　←見出し行
01　りんご　100円　 5個　500円
02　みかん　50円　10個　500円

このようなデータがはいっています。
データ件数は可変です。

これを一つの新規シートに集計するコードは
http://www.moug.net/tech/exvba/0040062.html

Sub Sample()

    Dim sWS As Worksheet  'データシート（コピー元）
    Dim dWS As Worksheet  '集約用シート（コピー先）

    Set dWS = Worksheets("AllData")

    '集約用シートの2行目以降を削除
    dWS.UsedRange.Offset(1, 0).Clear

    '各シートの2行目以降のデータを、集約用シートの末尾にコピー
    For Each sWS In Worksheets
        If sWS.Name <> dWS.Name Then
            With sWS.UsedRange

                'コピー元シートにデータが1件以上ある場合
                If .Rows.Count > 1 Then
                    .Offset(1, 0).Resize(.Rows.Count - 1).Copy _
                        Destination:=dWS.Cells(Rows.Count, 1). _
                                        End(xlUp).Offset(1, 0)
                End If

            End With
        End If
    Next sWS

    '集計用シートをA列で並べ替え
    dWS.UsedRange.Sort Key1:=Range("A1"), Header:=xlYes
End Sub

これを参考に作れました。

ただ、今回はどの各行のデータがどのシートのデータなのか明らかにする必要があり、
下記イメージのような集計の仕方をしたいと思っています。

11月1日←シート名
ID　名前　　値段　個数売上　←見出し行
01　りんご　100円　 5個　500円
02　みかん　50円　10個　500円

11月2日←シート名
ID　名前　　値段　個数売上　←見出し行
01　りんご　100円　 5個　500円
02　みかん　50円　10個　500円

11月3日←シート名
ID　名前　　値段　個数売上　←見出し行
01　りんご　100円　 5個　500円
02　みかん　50円　10個　500円
03　いちご　300円　 1個　300円

11月4日←シート名
ID　名前　　値段　個数売上　←見出し行
01　みかん　50円　10個　500円

このようにシート名をつけてその次の行から見出し、データをコピー
最後の行までいったら2回改行して、シート名をつけて～といった
処理を行いたいと思っています。

上のソースでOffsetをつかってセルを移動しながらコピーを行っているみたいですが、
このあたりへの理解が浅く、シート名を取得してもどうやって思ったとおりの位置のセルにシート名を代入するのか
わからず困っています。

 Dim sWS As Worksheet  'データシート（コピー元）
   Dim dWS As Worksheet  '集約用シート（コピー先）

   Set dWS = Worksheets.Add()
   dWS.Name = "AllData"
   For Each sWS In Worksheets
       If sWS.Name <> dWS.Name And sWS.Name <> "マクロ" Then
           With sWS.UsedRange

               'コピー元シートにデータが1件以上ある場合
               If .Rows.Count > 2 Then
                   .Offset(1, 0).Resize(.Rows.Count - 1).Copy _
                       Destination:=dWS.Cells(Rows.Count, 1). _
                                       End(xlUp).Offset(1, 0)
               ActiveCell.Value = sWS.Name
               End If

           End With
       End If
   Next sWS

   試しに作ってみたのはほとんど変更を加えてないこのコードです。
   シート名を記入するようにしていますが試しに走らせて見たところ、

   1行目には一番最後のシート名
   2行目以降はデータのみで見だしが入らない状態です。

 Sub pileUp()
     Dim sWS As Worksheet  'データシート（コピー元）
     Dim dWS As Worksheet  '集約用シート（コピー先）
     Dim cellToPaste As Range

     On Error Resume Next
         Set dWS = Worksheets("AllData")
         If Err.Number <> 0 Then
             Set dWS = Worksheets.Add()
             dWS.Name = "AllData"
         End If
     On Error GoTo 0

     '集約用シートを先行クリア
     dWS.UsedRange.Clear

     For Each sWS In Worksheets
        If sWS.Name <> dWS.Name And sWS.Name <> "マクロ" Then
            With sWS.UsedRange
                'コピー元シートにデータが1件以上ある場合
                If .Rows.Count > 1 Then
                     Set cellToPaste = dWS.Cells(Rows.Count, 1).End(xlUp). _
                         Offset(IIf(IsEmpty(dWS.Range("A1")), 1, 3), 0)
                    .Copy Destination:=cellToPaste
                    cellToPaste.Offset(-1) = sWS.Name

                End If
            End With
        End If
    Next

 End Sub

（半平太） 2013/11/08(金) 16:33

コメント返信：

[ 一覧(最新更新順) ]

[[20131108144024]] 『複数シートのデータを一つのシートに集計する際、』（kenj） ページの最後に飛ぶ

[[20131108144024]]　『複数シートのデータを一つのシートに集計する際、』（kenj）　ページの最後に飛ぶ