エクセル グループごとに一つのセルに纏める方法

質問

教えて下さい。
エクセル2003で仮に以下のような表があるとします。

「１」「２」
あ　　A
あ　　B
あ　　C
い　　A
い　　B
う　　Ａ
う　　B
う　　C
う　　Ｄ

別のシートのセルでも、同一セルでもいいのですが、
「１」「２」
あ　　AＢＣ
い　　AＢ
う　　ＡＢＣＤ

いう風にグループごとにひとつのセルにデータを纏めたいのですが、
何かよい方法はありませんでしょうか？

あまりエクセルが詳しくありません。
宜しくお願い致します。

回答No.1

merlionXX · ベストアンサー

データは、Sheet1のA列とB列にあるものとします。
もしシート名がちがうならｍか気のコードのSheet1を変更するか、シート名をSheet1にしてください。
お書きのようにA列が順序良く並んでいなく、バラバラでもぜんぜんかまいません。
新しいシートを追加して、AB列に転記します。

以下の手順をお試しください。
とても簡単です。

1.AltキーとF11キー同時に押し（以下Alt+F11キーと記述）て Visual Basic Editor を呼び出します。
2.Visual Basic Editor のメニューから「挿入」、「標準モジュール」で出てきたコードウィンド（右側の白い広い部分）に以下のコード（Sub～End Sub）をコピペします。

'********これより下**********

Sub test()
　　Dim myDic As Object
　　Dim i As Long
　　Dim ws As Worksheet
　　Set myDic = CreateObject("Scripting.Dictionary")
　　With Sheets("Sheet1")
　　　　For i = 1 To .Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　If Not myDic.Exists(.Cells(i, "A").Value) Then
　　　　　　　　myDic.Add .Cells(i, "A").Value, .Cells(i, "B").Value
　　　　　　Else
　　　　　　　　myDic(.Cells(i, "A").Value) = myDic(.Cells(i, "A").Value) + .Cells(i, "B").Value
　　　　　　End If
　　　　Next i
　　End With
　　Set ws = Sheets.Add
　　ws.Range("A1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.keys)
　　ws.Range("B1").Resize(myDic.Count, 1).Value = Application.Transpose(myDic.items)
　　Set myDic = Nothing
　　Set ws = Nothing
End Sub

'********これより上**********

3.Alt+F11キーでワークシートへもどります。
4.Alt+F8キーで出てきたマクロ名（test01）を選択して実行します。
5.新しいシートが追加され、そこにご希望の結果があるはずです。

お礼

早々のご回答本当にありがとうございました。
思っていたとおりのデータを作成させることが出来ました。
感謝しております。
ありがとうございました。

回答No.3

MackyNo1

結果を右側の列のセルにそれぞれ分割して表示するなら、以下のような数式を入力します。

D2セル（下方向にオートフィル）

=INDEX(A:A,SMALL(INDEX((MATCH(A$1:A$1000&"",A$1:A$1000&"",)<>ROW(A$1:A$1000))*100+ROW(A$1:A$1000),),ROW(A1)))&""

E2セル（右方向および下方向にオートフィル）
=INDEX($B:$B,SMALL(INDEX(($A$1:$A$1000<>$D2)*1000+ROW($B$1:$B$1000),),COLUMN(A1)))&""

お礼

ご回答ありがとうございます。
無事に完成させることが出来ました。
本当にありがとうございました。

回答No.2

tom04

こんばんは！
すでに回答は出ていますので・・・参考程度で！

列方向の別セルに一つずつ表示させるのであれば関数で対応できると思いますが、
一つのセルに表示したいということなので、一例です。

Sheet1のデータをSheet2に表示するようにしてみました。
Altキーを押しながらF11キーを押します、VBE画面が出ますので、
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
Excel2003の場合は
メニュー　→　ツール　→　マクロ　→　マクロ　→　実行　でOKです。
尚、両Sheetとも1行目はタイトル行があるものとしています。

Sub test()
Dim i, j As Long
Dim str, buf As String
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
If WorksheetFunction.CountIf _
(ws1.Range(Cells(2, 1), Cells(i, 1)), ws1.Cells(i, 1)) = 1 Then
ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1) = ws1.Cells(i, 1)
End If
Next i
For j = 2 To ws2.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row

If ws2.Cells(j, 1) = ws1.Cells(i, 1) Then
str = ws1.Cells(i, 2)
buf = buf & str
End If
ws2.Cells(j, 2) = buf
Next i
buf = ""
Next j
ws2.Columns(2).AutoFit
End Sub

こんな感じではどうでしょうか？m(__)m

お礼

ご回答ありがとうございました。
何とか作り上げることが出来ました。
本当にありがとうございました。