縦持ちのデータを横持ちにする方法

以下のように各ID毎に、縦持ちでデータを持っているとします。

ID データ
ABC golf
ABC baseball
ABC basketball
DEF baseball
DEF soccer
GHI soccer
GHI golf
GHI volleyball
GHI basketball
JKL swimming


それを以下のように各ID毎に、横持ちで1行で表したいです。　

ABC golf, baseball, basketball
DEF baseball, soccer
GHI soccer, golf, volleyball, basketball
JKL swimming

ID数が膨大で、かつデータの種類が多岐に渡るため、
エクセルでなくても構わないのですが、上記を簡単に実現できる方法をご存知の方教えてください！

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

No.3 回答者： mike_g 回答日時： 2016/11/01 10:27

マクロ音痴な私なら、[No.2]の d-q-t-pさんのアイディアに飛び付いてソレで終わりです。

だけど、それまでにアーでもない、コーでもないと考えていたので、私自身の備忘録そして貴方への別解として、記しておきます。

「縦持ちデータ」を添付図の Sheet1 とします。それを「横持ちデータ」として Sheet2 に実現します。
ちなみに、初耳の「縦持ち(横持ち)」、中々乙な表現ですね。どの業界の言葉なのでしょうか？

１．Sheet1 の列Ａを[コピー]して、Sheet2 の列Ｃに[貼り付け]
２．Sheet2 の列Ｃを選択して、[データ]→
￣￣[データツール <重複の削除>]
３．下の各セルにそれぞれ右側の式を入力
￣￣ A2: =MATCH(C2,Sheet1!A:A,0)
￣￣ B2: =COUNTIF(Sheet1!A:A,C2)
￣￣ D1: =IF(COLUMN(A1)>MAX($B:$B),"","Events"&COLUMN(A1))
￣￣ D2: =IF(COLUMN(A1)>$B2,"",OFFSET(Sheet1!$A$2,$A2-2+COLUMN(A1)-1,1))
４．範囲 A2:B2 のフィルハンドルをマウスで「エイヤッ！」
￣￣とダブクリ
５．セル D1 を右方へズズーッとオートフィル
６．セル D2 を右方へ(１行目が表示されている列まで。此処で
￣￣はセル G4 まで)ズズーッとオートフィル
７．範囲 D2:G2 のフィルハンドルをマウスで「エイヤッ！」
￣￣とダブクリ

この回答へのお礼

ありがとうございます！　
OFFSET関数など難しいですね。。。
どんな処理をしているのか、がよくわかっていませんが、実現できました。
こんな方法もあるんですね。
ありがとうございます。

お礼日時：2016/11/01 11:50

No.2 回答者： d-q-t-p 回答日時： 2016/10/31 17:14

この「, 」がセルで分けるのか何なのかよく分かりませんが 見たまま

だと解釈します。

A列が昇順にソート
C2：=IF(A2=A3,B2&", "&C3,B2)
フィルハンドルをダブルクリック
C列をコピー→その場で値貼り付け
[データ]の[重複を削除]
ID列を指定して[OK]
B列を削除

でいいと思います。

この回答へのお礼

一つのセルにカンマ区切りで値をすべて入れられるのはものすごく良いですね！
本当はセルは分けたかったのですが、CSVで保存すればほとんど同じことですね。
マクロも使わず解決できるのは素晴らしい方法です。
ありがとうございます！

お礼日時：2016/11/01 10:29

No.1 ベストアンサー 回答者： tom04 回答日時： 2016/10/31 16:55

こんにちは！

＞それを以下のように各ID毎に、横持ちで1行で表したいです。
セルは別々になっても良い！というコトとして・・・

VBAになりますが、一例です。
元データはSheet1にあり、Sheet2に表示するとします。
尚、Sheet1の1行目は項目行でデータは2行目以降にあるという前提です。
標準モジュールにしてください。

Sub Sample1() 'この行から//
Dim i As Long, c As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
wS.Cells.ClearContents
With Worksheets("Sheet1")
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
wS.Cells(c.Row, Columns.Count).End(xlToLeft).Offset(, 1) = .Cells(i, "B")
Next i
End With
Application.ScreenUpdating = True
wS.Activate
MsgBox "完了"
End Sub 'この行まで//

※　関数でないのでデータ変更があるたびに
マクロを実行する必要があります。m(_ _)m

この回答へのお礼

実現したいことが一瞬で実現できました！
ありがとうございます！！

お礼日時：2016/11/01 10:29