一つのセルにまとめる

質問

A列が同じ値の範囲の、B列の重複していない文字をC列に書き出すか、一つのセルにまとめたいです。
もう頭が回らない為、知恵を貸して頂けるとありがたいです。

第一希望
A列 B列 C列
くま組 gさん gさんjさんmさん
くま組 jさん
くま組 mさん
りす組 aさん aさんgさん
りす組 gさん
さる組 pさん pさんjさんcさん
さる組 jさん
さる組 pさん
さる組 cさん

第二希望
A列 B列 C列
くま組 gさん gさん
くま組 jさん jさん
くま組 mさん mさん
りす組 aさん aさん
りす組 gさん gさん
さる組 pさん pさん
さる組 jさん jさん
さる組 pさん cさん
さる組 cさん

回答No.4

nishi6

質問にあるように組が並んでいる状態で関数を作ってみました。A列は「組」、B列は「名前」、C、D、F列は作業用列。E列は「第一希望」、G列が「第二希望」です。Sheet1で計算しています。

C2:　=A2&"_"&B2
D2:　=IF(A2<>A1,B2,IF(COUNTIF(C$2:C2,C2)=1,D1&","&B2,D1))
E2:　=IF(A2<>A1,INDEX(D2:D$10000,COUNTIF(A:A,A2),1),"")
F2:　=IFERROR(IF(A2<>A1,E2,MID(F1,FIND(",",F1)+1,LEN(F1))),"")
G2:　=LEFT(F2,FIND(",",F2&",")-1)

入力が終わったら、セル範囲C2:G2を下にコピーします。式を簡素化するために、データは１万件未満としています。
セルE2の「10000」がそれに当たります。必要なら増やしてください。C、D、F列は作業用列なので非表示にしてもかまいません。関数の場合、組の最初に書いたり、詰めて書くのが面倒なので補助列を使っています。シートの状態は添付図を参照してください。

VBAは簡単にできるので合わせて書いておきます。

Sheet2にSheet1のA、B列の値を貼り付けてください。表題と「くま組」～「さる組」の10行２列です。VBAは何行あっても動きます。AB列に質問のようなデータが入力されていればいいです。

●「開発」タブをクリックして「Visual Basic」ボタンをクリックします。（または ALTキー+F11キー を押します）
●Microsoft Visual Basic for Applications の画面が開きます。（VBE）
●VBE画面の左にプロジェクト画面が表示されていなかったら、メニューから、表示＞プロジェクトエクスプローラーを選択します。
●プロジェクトエクスプローラーが表示されたら、ツリー表示の「Sheet2」をダブルクリックします。
●表示された広い画面に回答したコート（「Sub まとめ()　～　End Sub」になります）をコピーして貼り付けます。

●ExcelのSheet2に戻って、「開発」タブ＞「マクロ」ボタンをクリックして、「Sheet2.まとめ」を選択して「実行」ボタンをクリックします。
　※「開発」タブの表示はされているものとしています。

Sub まとめ()
　　Dim rw As Long　　　　　　 '// 行カウンタ
　　Dim rwWrite1 As Long　　　'// 第一希望書き出し行
　　Dim rwWrite2 As Long　　　'// 第二希望書き出し行
　　Dim Kumi As String　　　　 '// 組
　　Dim Ketsugou As String　　'// 第一希望の結合結果

　　Range("C:D").ClearContents　　'// 結果出力列をクリア
　　Range("C1:D1") = Array("第一希望", "第二希望")

　　With Range("B2")
　　　　While .Offset(rw, 0) <> ""
　　　　　　'// 組の最初の行で初期化
　　　　　　rwWrite1 = rw: rwWrite2 = rw: Kumi = .Offset(rw, -1)
　　　　　　Ketsugou = .Offset(rw, 0)
　　　　　　.Offset(rwWrite2, 2) = .Offset(rw, 0) '// 第二希望

　　　　　　rw = rw + 1
　　　　　　'// 同一組の場合
　　　　　　While .Offset(rw, -1) = Kumi
　　　　　　　　If InStr(Ketsugou, .Offset(rw, 0)) = False Then
　　　　　　　　　　'// 重複してなければ結合する
　　　　　　　　　　Ketsugou = Ketsugou & .Offset(rw, 0)
　　　　　　　　　　'// 第二希望
　　　　　　　　　　rwWrite2 = rwWrite2 + 1
　　　　　　　　　　.Offset(rwWrite2, 2) = .Offset(rw, 0)
　　　　　　　　End If

　　　　　　　　rw = rw + 1
　　　　　　Wend

　　　　　　.Offset(rwWrite1, 1) = Ketsugou '// 第一希望
　　　　Wend
　　End With
End Sub

関数を使うほうが興味深いですね。

回答No.3

mp20palpunte

重複しない、ユニークな○○さんを抽出したい、ということなんでしょうか？
それであれば、逆に、重複をピックアップして、フィルタで非表示にするというのはどうでしょう。

C列に
=IF(COUNTIF($B$2:B2,B2)>1,"重複","")
と入れ、全行にコピーしてください。

名前が重複している、二個目から「重複」と表示されます。

フィルタで、C列を空白セルにのみチェックすれば、重複しないデータだけになります。

回答No.2

tom04

こんにちは！

＞一つのセルにまとめたいです。
というコトですので、VBAになってしまいますが一例です。

↓の画像のように元データが左側（Sheet1）のようになっていて、
右側のSheet2に表示させるとします。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻りマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, str As String, c As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
wS.Cells.Clear
With Worksheets("Sheet1")
.Range("A:A").AdvancedFilter Action:=xlFilterInPlace, unique:=True
.Range("A:A").Copy wS.Range("A1")
.ShowAllData
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)
If wS.Cells(c.Row, "B") = "" Then
wS.Cells(c.Row, "B") = .Cells(i, "B")
Else
If InStr(wS.Cells(c.Row, "B"), .Cells(i, "B")) = 0 Then
wS.Cells(c.Row, "B") = wS.Cells(c.Row, "B") & "," & .Cells(i, "B")
End If
End If
Next i
wS.Columns.AutoFit
End With
End Sub 'この行まで

こんな感じではどうでしょうか？m（_ _）m

お礼

まさにこれです。こういう結果を出したかったんです。
書き出し場所を少し修正して活用させて頂きたいと思います。

やっぱりマクロ勉強しなきゃダメですね。

わかりにくい質問を読み取っていただきありがとうございました。

回答No.1

RandenSai

今の指定条件と、例示の第1希望・第2希望が全くつながらないんですが…

疑問点:
A列 くま組
B列 gさん
C列 gさんjさんmさん ←jさんmさんはどこから湧いて出てきた？

とにかく、セルの文字列の検索や抽出は、次の解説が答えです。この解説の下の方にある、関連する記事というリンクにも大きなヒントがあります。

http://www.relief.jp/itnote/archives/000103.php

補足

質問内容が少し難しかったようで、すみませんでした。
2番の方の回答を見ていただければ理解頂けると思います。