同じグループの人のメアドを１つのセルにまとめたい

質問

添付の画像のように、同じグループの人のメアドを１つのセルにまとめる方法があれば教えてください。
（１グループのメアドは最大３個とは限りません。）
（もし、最後の人のメアドにもセミコロンがついちゃっても、メールを送る時には問題ないのでＯＫです。それか、最初からメアドデータにセミコロンつけておくのもＯＫです。）

よろしくお願いします。

回答No.1

watabe007 · ベストアンサー

マクロで宜しければ
Sub Test()
　Dim c As Range, myR As Variant
　For Each c In Range("A1", Cells(Rows.Count, "A").End(xlUp))
　　myR = Application.Match(c.Value, Columns(6), 0)
　　If Not IsError(myR) Then
　　　Cells(myR, "G").Value = Cells(myR, "G").Value & ";" & c.Offset(, 1).Value
　　Else
　　　With Cells(Rows.Count, "F").End(xlUp).Offset(1)
　　　　.Value = c.Value
　　　　.Offset(, 1).Value = c.Offset(, 1).Value
　　　End With
　　End If
　Next
End Sub

お礼

ありがとうございました。
いちばん作業工数が少なくて簡単でしたので、ベストアンサーとさせていただきました。

回答No.4

msMike

[No.3]に対してナシのツブテですかぁ～！

最大10個としておきませう。
ちなみに、貴方は明記してないけど、私のは Excel 2013 でっす。

お示しのシートを Sheet1 としておきます。
１．Sheet1 の列Ａを Sheet2 の列Ａにコピべ
以下は Sheet2 における操作です。
２．Sheet2 の列Ａ選択 ⇒ Alt+AM ⇒ “現在選択されている範囲を
￣￣並べ替える”に目玉入れ ⇒ [重複の削除]をチョーン ⇒ [OK] ⇒
￣￣[OK]
３．式 =COUNTIF(Sheet1!A1:A10,A1) のフィルハンドルを
￣￣「エイヤッ!」とダブクリ
４．次式を入力したセル C1 を右方にズズーッと(セル L1 まで)
￣￣オートフィル
￣￣ =IF(COLUMN(A1)>$B1,"",INDEX(Sheet1!$B$1:$B$10,SMALL(IF(Sheet1!$A$1:$A$20=$A1,ROW($A$1:$A$20)),COLUMN(A1))))
￣￣【お断り】上式は必ず配列数式として入力のこと
５．範囲 C1:L1 のフィルハンドルを「エイヤッ!」とダブクリ
以下kは Sheet3 における操作です。
６．列Ａは空白のまま放置して、式 =A1&" "&Sheet2!C1 を入力
￣￣したセル B1 を右方にズズーッと(セル K1 まで)オートフィル
７．範囲 B1:K1 を下方にオートフィル(その必要行数は実行して
￣￣みれば自ずから判明！)
以下は Sheet1 における操作です。
８．式 =SUBSTITUTE(TRIM(Sheet3!K1)," ","; ") を入力したセル
￣￣G1 を下方にオートフィル

お礼

なかなか見に来られなくてすみません。10個でOKでした。ありがとうございました。

回答No.3

msMike

》 １グループのメアドは最大３個とは限りません。）
じゃあ、最大何個とすれば御の字ですか？
5個？10個？50個？100個？1000個？まさかぁ！

回答No.2

imogasi

処理ステップは大きく分けて
（１）修正キーを作成
（２）ソート
（３）完成表作成
Ｓｐｌｉｔ関数の多用が特徴。
ーー
Ｓｈｅｅｔ１　元データシート
Ｓｈｅｅｔ３　完成表シート　（Ｂ列は幅を十分広く取っておく）
ーー
例データ　Ｓｈｅｅｔ１のＢ、Ｃ、Ｄ列
ただしＣ，Ｄ列はプログラムで作成し付け加えたもの
Ｄ列データは、後処理に重要。
Ｂ列　　　　　Ｃ列　　　　Ｄ列
aaa@kuma.ne.jp　　 kuma.ne.jp　　 kuma
ddd@kuma.ne.jp　　 kuma.ne.jp　　 kuma
bbb@1.neko.ne.jp　　1.neko.ne.jp　　　 neko
fff@2.neko.ne.jp　　　2.neko.ne.jp　　　 neko
ccc@usagi.com　　 usagi.com　　　 usagi
eee@usagi.com　　 usagi.com　　　 usagi
ggg@usagi.com　　 usagi.com　　　 usagi
ーーー
標準モジュールに
Sub urlhenkei2()
Worksheets("Sheet1").Select
lr = Worksheets("Sheet1").Range("B100000").End(xlUp).Row
MsgBox lr
For i = 1 To 7
w = Cells(i, "B")
'---第１文字から、@までを削除ーー＞結果Ｃ列へセット
p = Split(w, "@")
w = p(1) 'wは＠マーク以後文字列
Cells(i, "C") = p(1)
'========================
'---ピリオドの数をカウント
w1 = Replace(w, ".", "") 'ピリオッドを消して
psuu = Len(w) - Len(w1) '減少文字数を計算
'=======
v = Split(p(1), ".")
'-ピリオドの数で、場合分け
Select Case psuu
'--結果Ｄ列にセット
'---
Case 1 '1つの場合
Cells(i, "D") = v(0)
'---
Case 2 '2つの場合
v = Split(p(1), ".")
Cells(i, "D") = v(0)
'---
Case 3 '3つの場合
Cells(i, "D") = v(1)
'---
End Select
Next i
'=====
'--D列でソート
Range("a1:d7").Sort key1:=Range("d1")
'＝＝＝＝結果表作成 　Sheet3に作る
'Ｓｈｅｅｔ３の　B列の列幅を十分広く設定のこと
k = 0
mae = ""
'---
For i = 1 To 7
If Worksheets("Sheet1").Cells(i, "D") = mae Then
Worksheets("Sheet3").Cells(k, "B") = Worksheets("Sheet3").Cells(k, "B") & "; " & Worksheets("Sheet1").Cells(i, "B")
mae = Worksheets("Sheet1").Cells(i, "D") 'Ｋｅｙ項目
Else
k = k + 1
Worksheets("Sheet3").Cells(k, "B") = Worksheets("Sheet1").Cells(i, "B")
mae = Worksheets("Sheet1").Cells(i, "D") 'Ｋｅｙ項目
End If
Next i
End Sub
ーー
Ｓｈｅｅｔ３は（１－３行目）
aaa@kuma.ne.jp; ddd@kuma.ne.jp
bbb@1.neko.ne.jp; fff@2.neko.ne.jp
ccc@usagi.com; eee@usagi.com; ggg@usagi.com
＝＝＝＝
質問文の
＞同じグループの人
の解釈（割り出し方）に不十分な点があるかもと、思いながら作った。
1.neko.ne.jpと2.neko.ne.jp2　は同グループと考えるのかな。ＩＳＰなどは、
会員によって、サーバーを分けている例は多いようだが。
別にして考える場合も、上記コードを数行修正すれば出来そうだが。

お礼

ありがとうございました。