エクセルマクロ◇別シートで個人ごとに数値の集計

質問

EXCEL２００３です。
以下のように、名前・個数・商品名（名前と商品名は重複あり）が列記されている
EXCELのデータを、別シートで商品名の個数を個人ごとに集計したいと思っています。

◇元データ◇

名前　個数　商品

A子　　２　　りんご
A子　　１　　りんご
A子　　３　　みかん
A子　　２　　みかん
A子　　１　　メロン
B子　　１　　みかん
B子　　１　　みかん
B子　　２　　メロン
B子　　４　　キウイ

◇集計データ◇

名前　りんご　みかん　メロン　キウイ

A子　　３　　　５　　　　１
B子　　　　　　２　　　　２　　　４

最初ピボットテーブルを使えばいいかと思っていたのですが、
これ以外にも元データから取得する値が出てくる予定のため、
できればマクロを組んで別シートに集計したいです。

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

回答No.4

tom04 · ベストアンサー

こんばんは！
VBAでないので的外れなら読み流してください。

↓の画像で説明させていただきます。

Sheet1のデータをSheet2にまとめるようにしてみました。

Sheet1に名前用と商品用の作業列を使わせてもらっています。

Sheet1のE2セルに
=IF(COUNTIF($A$2:A2,A2)=1,ROW(A1),"")
F2セルに
=IF(COUNTIF($C$2:C2,C2)=1,ROW(A1),"")
として、E2・F2セルを範囲指定し、F2セルのフィルハンドルで
下へずぃ～～～！っとコピーします。
（Sheet2の数式が1000行まで対応できるようにしていますので、そのくらいまでコピーしても構いません）

次にSheet2の商品名セルB1に
=IF(COUNT(Sheet1!$F$2:$F$1000)<COLUMN(A1),"",INDEX(Sheet1!$C$2:$C$1000,SMALL(Sheet1!$F$2:$F$1000,COLUMN(A1))))
として列方向にコピーします。

名前セルのA2に
=IF(COUNT(Sheet1!$E$2:$E$1000)<ROW(A1),"",INDEX(Sheet1!$A$2:$A$1000,SMALL(Sheet1!$E$2:$E$1000,ROW(A1))))

商品のB2セルに
=IF(OR($A2="",B$1=""),"",SUMPRODUCT((Sheet1!$A$2:$A$1000=Sheet2!$A2)*(Sheet1!$C$2:$C$1000=Sheet2!B$1),Sheet1!$B$2:$B$1000))
とし、列方向（商品名が空白でも構いません）にコピー

最後にA2～商品の列方向に数式をコピーした列の最後を範囲指定し、
最後の列のフィルハンドルで下へコピーすると
画像のような感じになります。

これで今後データが増えてもSheet2に反映されます。

以上、長々と書きましたが
参考になれば幸いです。m(__)m

お礼

画像までつけて説明していただきありがとうございました。
大変参考になりました。マクロではなくこの方法でいきたいと思います。

回答No.6

imogasi

（１）関数でも出来そうなこと
名前と商品は、データーフィルターフィルタオプションの設定ー重複するレコードは無視するで、重複のないリストを作る。
さらに商品は、コピーー形式を選択して貼り付けー行と列を入れ替えるで横方向にデータを流す。
あとはA列と商品列第１行目の値で、２条件でカウントする。
SUMPRODUCTかCOUNTIF（２００７）で出せる。
データ量が多いと重くなる心配はある。
他シートになる場合は、合計カウントを出す他シート側でフィルタオプションの設定をやる。
フィルタオプションの設定の操作がデータが増えても連動しない欠点は在る。
作業列をつかっって重複のないリストを作れば連動させられるが。
（２）ピボットでもデータ増減に対処して、再実行が出来ること
（３）VBAでも、（普通は）再実行はしないとならないコードだろうこと
など認識して、質問をしてますか。

回答No.5

Wendy02

こんばんは。

データ量によっては、#4さんのような数式の方に軍配が上がるかもしれません。私の方は、数千～1万行のデータを前提にしています。そのぐらいなら、数秒で終わります。それを超える場合は、少し内容を変えないといけません。

なお、元データは、ActiveSheet にしてください。

'-------------------------------------------

Sub TestMacro1()
　　Dim v As Variant
　　Dim i As Long
　　Dim j As Long
　　Dim n As Long
　　Dim sh2 As Worksheet
'-------------------------------------------
　　Set sh2 = Worksheets("集計データ")
　　'注意集計データは一旦全部削除されます。
　　sh2.Cells.ClearContents
'-------------------------------------------
　　Application.ScreenUpdating = False
　　With ActiveSheet.Range("A1").CurrentRegion
　　　　.Columns(1).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
　　　　For Each v In .Columns(1).SpecialCells(xlCellTypeVisible).Cells
　　　　　　i = i + 1
　　　　　　sh2.Cells(i, 1).Value = v
　　　　Next
　　　　.Columns(3).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
　　　　For Each v In .Columns(3).SpecialCells(xlCellTypeVisible).Cells
　　　　　　j = j + 1
　　　　　　If j > 1 Then
　　　　　　　　sh2.Cells(1, j).Value = v
　　　　　　End If
　　　　Next
　　　　ActiveSheet.ShowAllData
　　　　'データの出力（データ量が多い場合は、以下を変更）　　　
　　　　For n = 2 To .Rows.Count
　　　　　　i = Application.Match(.Cells(n, 1).Value, sh2.Columns(1), 0)
　　　　　　j = Application.Match(.Cells(n, 3).Value, sh2.Rows(1), 0)
　　　　　　sh2.Cells(i, j).Value = sh2.Cells(i, j).Value + .Cells(n, 2).Value
　　　　Next n
　　End With
　　Application.ScreenUpdating = True
　　sh2.Select
End Sub

お礼

大変ご丁寧にご説明いただきありがとうございました。

回答No.3

某HN クロメート(Chromate)（@CoalTar）

マクロではありませんm(_ _)m
＞これ以外にも元データから取得する値が出てくる予定のため
の意味しだいですが、ピボットテーブルの範囲を可変にして対応できませんか？

<元データ>シートにて
[Ctrl]+[F3]名前の定義
名前 : 元
参照範囲 : =$A$1:INDEX($C:$C,COUNTA($A:$A))

ピボットテーブルウィザードの範囲指定時に
=元

更新すると<元データ>シートに追加された値も計算対象となります。
参考まで

回答No.2

n-jun

関係ないかも知れませんが。

＞これ以外にも元データから取得する値が出てくる予定のため、
この”予定”によって対応が変化する可能性もあり得るかと。

的はずれでしたらごめんなさい。

回答No.1

nattocurry

項目行とデータ行の間に空行が無いもの（データが2行目から始まる）とすると、
こんな感じのマクロで、いけます。

Sub test()

Dim Sh0 As Worksheet, Sh1 As Worksheet
Set Sh0 = Worksheets("元データ")
Set Sh1 = Worksheets("集計データ")

Dim CellFound As Range

Dim r0 As Long, r1 As Long, c1 As Long

r0 = 2
Do Until IsEmpty(Sh0.Cells(r0, 1).Value)
Set CellFound = Sh1.Columns(1).Find(What:=Sh0.Cells(r0, 1).Value, LookAt:=xlWhole)
If CellFound Is Nothing Then
With Sh1.Cells(Sh1.Rows.Count, 1).End(xlUp).Offset(1)
.Value = Sh0.Cells(r0, 1).Value
r1 = .Row
End With
Else
r1 = CellFound.Row
End If
Set CellFound = Sh1.Rows(1).Find(What:=Sh0.Cells(r0, 3).Value, LookAt:=xlWhole)
If CellFound Is Nothing Then
With Sh1.Cells(1, Sh1.Columns.Count).End(xlToLeft).Offset(, 1)
.Value = Sh0.Cells(r0, 3).Value
c1 = .Column
End With
Else
c1 = CellFound.Column
End If
With Sh1.Cells(r1, c1)
.Value = .Value + Sh0.Cells(r0, 2).Value
End With
r0 = r0 + 1
Loop

End Sub