EXCELの関数またはマクロ教えてください。

質問

こんばんは。
よろしくお願いいたします。

EXCEL2000です。

(1)こんな縦に重複した名前の表を、
名前　コード　内訳名　金額
鈴木　　1　　　飴　　 \100
鈴木　　2 　　　ガム　 \150
鈴木　　4 　　　米　　 \1,000
鈴木　　6 　　　食器　 \500
佐藤　　1 　　　飴　　 \100
佐藤　　2 　　　ガム　 \200
佐藤　　3 　　　パン　 \300
田中　　1 　　　米　　 \1,300
田中　　2 　　　ガム　 \200
田中　　4 　　　米　　 \1,300
田中　　6 　　　食器　 \600

(2)横に一人一レコードにまとめたいのです。
　列の項目が内訳名になり増ますよね。
名前　　飴　　　　ガム　　パン　　　 米　　　　食器
鈴木　　\100　　　\150　　\1,000　　\500
佐藤　　\100　　　\200　　\300
田中　　\1,300　　\200　　　　　　　\1,300　　 \600

(3)欲を言えば、飴とガムは合計したいです。これが最終形態です。
名前　お菓子　パン 　　米　 食器
鈴木　\250　　\1,000　\500
佐藤　\300　　\300
田中　\1,500　\1,300　　　　\600

せめて(1)から(2)にする方法で何かよい関数などないでしょうか。
でなくても、「はじめからこんなマクロ・VBAでこんなのできるよ。」
なんてのがあれば、モジュールで教えてください。
本当に本当によろしくお願いいたします。
このデータは後、３００くらいあります。
私のレベルは、MOS上級取得なので、多少理解力はあるかと思います。
というか、必死で頑張りますのでお願いします。m(__)m

回答No.3

otasuke009 · ベストアンサー

わたしはピボットテーブルが使えません……。
関数で処理するとすれば、元の表が

A B C D
1 名前 コード 内訳名 金額
2 鈴木 1 飴 100　
3 鈴木 2 ガム 150　
4 鈴木 4 米 1000　
5 鈴木 6 食器 500　
6 佐藤 1 飴 100　
7 佐藤 2 ガム 200　
8 佐藤 3 パン 300　
9 田中 1 米 1300　
10 田中 2 ガム 200　
11 田中 4 米 1300　
12 田中 6 食器 600　

として

F G H I J K
1 名前 飴 ガム パン 米 食器
2 鈴木 100 150 1000 1000 500
3 佐藤 100 200 300 0 0
4 田中 0 200 1300 2600 600

のようにするには、(2)

G2 セルに =SUMPRODUCT(($D$2:$D$12)*(($A$2:$A$12)=$F2)*(($C$2:$C$12)=G$1))
を入力して G2:K4 セルにコピーします。

お礼

ありがとうございます。
夜中に必死で質問したので、見出しやコードがズレズレに張りいてしまったのに、見事に私の意図するものをあらわしてくれたこと感謝です。
SUMPRODUCT勉強します。
夜中にありがとうございました。頑張ります。

回答No.7

Wendy02

追伸:

バグが残っていました。
Sub 集計1()側の

　With Sh2
　　j = 2 '次のシートの2行目書き出し
　　.Range("B1").Resize(, UBound(uchiwakes)).Value = _
　　uchiwakes

　With Sh2
　　j = 2 '次のシートの2行目書き出し
　　.Range("B1").Resize(, UBound(uchiwakes)+1).Value = _
　　uchiwakes

どうも、すみません。

お礼

本当にありがたいです。
Wendy02さんいい人ですねえ。

回答No.6

Wendy02

#5 です。
二つのミスを見つけましたので、飴とガムを集計するマクロの修正します。

Sub 集計2()
Dim Rng As Range, c As Range
'シートを選択（念のため）
Worksheets("Sheet2").Select
Set Rng = Range("A1", Range("A65536").End(xlUp)).Offset(, 1)
Application.ScreenUpdating = False
'重複実行防止
If Rng.Cells(1, 1).Value = "お菓子" Then Exit Sub
　Rng.Cells(1, 1).Value = "お菓子"
For Each c In Rng
　　If VarType(c) <> vbString Then
　　c.Value = c.Value + c.Offset(, 1).Value
　　End If
Next c
Rng.Offset(, 1).EntireColumn.Delete
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

お礼

重ね重ね大変恐縮です。
勉強させていただいております。

回答No.5

Wendy02

こんにちは。
データが、300程度は、どちらかというと、関数が向いているような気がします。
ただ、VBAのお話も出ていましたので、少し、私も考えてみました。

元のデータの振り分けをコードで行っていたようですが、元のデータには、コードと内訳名が違っていましたので、やむを得ず、内訳名で振り分けすることにしました。

　m = Application.Match(c.Offset(, 2).Value, uchiwakes, 0) + 1
　　　　　　　　　　　　内訳名　　　　　　　　内訳名のリスト

本来は、数字で振り分けるのが確実です。
また、以下のプログラムは、すでに出来上がった表ですと、半分以下になるのですが、表の項目から作るので長くなりました。

'<標準モジュールでお使いください。>
Option Explicit
Sub 集計1()
　Dim objDic1 As Object
　Dim Sh2 As Worksheet
　Dim dataRng As Range, c As Range, k As Variant
　Dim uchiwakes As Variant, i As Long, j As Long
　Dim myData(), n As Variant, m As Variant
　'出力先
　Set Sh2 = Worksheets("Sheet2")
　'データの名前の範囲
　Set dataRng = Range("A2", Range("A65536").End(xlUp))
　'内訳名(おそらくコードで別けているはず)
　uchiwakes = Array("飴", "ガム", "パン", "米", "?", "食器")
　Set objDic1 = CreateObject("Scripting.Dictionary")
　i = 1
　'名前
　For Each c In dataRng
　　If objDic1.Exists(c.Value) = False Then
　　　objDic1.Add c.Value, i
　　　i = i + 1
　　End If
　Next c
　With Sh2
　　j = 2 '次のシートの2行目書き出し
　　.Range("B1").Resize(, UBound(uchiwakes)).Value = _
　　uchiwakes
　　For Each k In objDic1.keys
　　　.Cells(j, 1).Value = k
　　　j = j + 1
　　Next k
　　'マトリックス並べ替え(Main)
　　For Each c In dataRng
　　　n = Application.Match(c, objDic1.keys, 0) + 1
　　　m = Application.Match(c.Offset(, 2).Value, uchiwakes, 0) + 1
　　　If Not (IsError(n) Or IsError(m)) Then
　　　 .Cells(n, m).Value = c.Offset(, 3).Value
　　　End If
　　Next c
　End With
　'Call 集計2　''続けて行う場合は、これを外す
　Set dataRng = Nothing
　Set Sh2 = Nothing
End Sub

'飴とガムを集計するマクロ
Sub 集計2()
Dim Rng As Range, c As Range
'シートを選択（念のため）
Worksheets("Sheet2").Select
Set Rng = Range("B1", Range("B65536").End(xlUp))
Application.ScreenUpdating = False
'重複実行防止
If Rng.Cells(1, 1).Value = "お菓子" Then Exit Sub
　Rng.Cells(1, 1).Value = "お菓子"
For Each c In Rng
　If VarType(c) = vbDouble Then
　　c.Value = c.Value + c.Offset(, 1).Value
　End If
Next c
Rng.Offset(, 1).EntireColumn.Delete
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

お礼

ここのお礼がなかったですね。すみません。
そうそう、これを元にいいのができました。
コマンドボタンをつけて、ボタン１つで誰でも集計できるものが完成しました。本当にありがとうございました。

補足

コードは、1が飴　2がガム　 3がパン　4が米　6が食器
としたつもりだったのが、ズレズレで大変しつれいいたしました。
なのに、こんな立派なものを・・・・(;_;)
ありがとうございます。
データは300は氷山の一角にすぎませんでした・・・。(*_*;

ここまで作っていただいて大変恐縮なのですが、時間があったらで結構です。コードを上記のものとして、もう一度チャンスをいただけないでしょうか・・・。

回答No.4

kaisendon

２です

深夜に寝ぼけてました～

＞右に横にコピー
は、右に下にコピー　の間違いでした。

(*_ _)ゴメンナサ～イ

お礼

いえいえ、大丈夫です。
わざわざありがとうございます。
私も寝ぼけてズレズレの表でわかりずらくてごめんなさい。

回答No.2

kaisendon

こんばんは

（１）の表をＡ１：Ｄ１２
（２）の表をＡ１５：Ｆ１８
（３）の表をＡ２０：Ｅ２３として考えました。
以下に記載されているセル番地は、上記から判断して下さい。

＞田中　　1 　　　米　　 \1,300
これは　飴　の間違いだと判断しました。

金額は整数で入力されているものを表示形式で通貨スタイルにしているものと考えました。

（２）（３）の表にコードの項目が無いので
（１）の表のコードは無視しました。

ゼロ値の処理はしていませんが、必要に応じて
ご自身で調整できると思い省略しました。

（２）の場合
Ｂ１６に　=SUMPRODUCT(($A$2:$A$12=$A16)*($C$2:$C$12=B$15),$D$2:$D$12)
右に横にコピー

（３）の場合
（１）の表のＥ列を作業列に使い
Ｅ２に　=IF(OR(C2="飴",C2="ガム"),"お菓子",C2)　下方向にコピー
Ｂ２１に　=SUMPRODUCT(($A$2:$A$12=$A21)*($E$2:$E$12=B$20),$D$2:$D$12)
右に横にコピー

お礼

ありがとうございます。
SUMPRODUCT勉強します。
やはりこういう場合は関数なんですね。
また質問文の表データがズレズレでわかりにくかったこと、
お詫び申し上げます。m(__)m

回答No.1

melgirl

関数ではなくエクセルのピボットテーブルを使うのが簡単です。数秒で(1)のリストが(2)の表に変わりますよ。
ピボットテーブル分かりますか？？

まず（１）のリスト（見出し付き）はエクセルに既に用意されているのですよね。そしたらツール→ピボットテーブルとピボットグラフレポート、を選択します。後はウィザードに従って作るだけなんですが、そのまま次へボタンを押すと、リスト範囲が自動で選択されると思います。うまく選択されていなかったらご自分で見出しを含む全てのデータを選択して下さい。
でそのまま完了ボタンです。

そうすると新規ワークシートになにやら作成されたと思いますが、行のフィールドに氏名をドラッグ＆ドロップ、列のフィールドに内訳名をドラッグ&ドロップ、データアイテムに金額をドラッグ＆ドロップします。
これで（２）の表が一気に完成です。

というか質問様の(1)のリストからは(2)の表にはならない^^;と思いますが・・・これは金額合計ミスですよね？田中さんは(1)では飴を買ってないのに(2)では1300円費やしていることになっているので・・・

これはさておき、

(3)をするには(1)のリストに小細工します。
金額の横の列に内訳名２という見出しで次のような関数を先頭行に入れ、一気に下までセル右端にカーソルを当てドラッグコピーしてください。

=IF(OR(B2=1,B2=2),"お菓子",C2)

行１は見出しで2行目からデータ、また
A列＝氏名、B列＝コード、C列＝ 内訳名、D列＝金額とします。またここではコード=1は飴、コード=2はガムという定義で間違いないですよね。

これをしてから先ほど説明したピボットテーブルを作ります。今度は行のフィールドに氏名をドラッグ＆ドロップ、列のフィールドに内訳名２をドラッグ&ドロップ、データアイテムに金額をドラッグ＆ドロップします。
これで（３）の表が一気に完成です。

お礼

どーもです～。
表の転記ミスですねえ。すみません。
Excelで作って、メモ帳に張りつけまたまではよかったのですが、
ここに貼り付けたらズレズレになり、大変な思いをしましたもので・・・。
試してみます。ありがとうございました。