EXCEL VBA を教えて下さい。

質問

EXCEL VBA で　業務毎に（A業務、B業務、C業務）、
担当者のメールアドレスを抽出するツールを
作りたいです。
＜Sheet1＞
　　　A列　　　B列　　　C列　　　D列　　　E列
　　　氏名　　メアド　　A業務　　B業務　　C業務
　　　111　　　111@aaa　　　to　　　cc　　　bcc
　　　222　　　222@bbb　　　cc　　　bcc　　to
　　　333　　　333@ccc　　　bcc　　to　　　cc
　　　444　　　444@ddd　　　to　　　cc　　　bcc

もしも、A業務のセルををクリックしたら、、、
Sheet２に下記のように表示するものを作りたいです。

＜Sheet2＞
to：　　　 111@aaa,444@ddd
cc：　　　 222@bbb
bcc：　　　333@ccc

なんとか下記まで書いてまましたが、知識が未熟な為、行き詰っています。
Sub Macro03()
With Worksheets("Sheet1").Range("A1")
.AutoFilter Field:=3, Criteria1:="to"

　　（　B列の対象メアドをカンマで連ねてコピーしたいのですがわからないです）
.CurrentRegion.SpecialCells(xlVisible).Copy Worksheets("Sheet2").Range("B2").PasteSpecial Paste:=xlValues, Transpose:=True
.AutoFilter
End With
Worksheets("Sheet2").Activate
End Sub

VBAの優秀な方、
どうか教えて下さいますよう、宜しくお願い致します。

回答No.4

watabe007

Ａ　　　　　Ｂ
　to：　　111@aaa,444@ddd
　cc：　　222@bbb
　bcc：　 333@ccc

のように出力するのなら

　　With Sheets("Sheet2")
　　　　For Each d In myDic.keys
　　　　　　j = j + 1
　　　　　　.Cells(j, "A").Value = d & "："
　　　　　　.Cells(j, "B").Value = myDic(d)
　　　　Next
　　End With
　　Set myDic = Nothing
End Sub

お礼

素晴らしいです！！
前者の方に続き、本当にありがとうございます！！
おふたりから理想どおりの回答を頂けて、感動しまくりです☆。

上司から頼まれたものの、どうしようかと悩んでいました。
（派遣社員なのですが、）お陰で派遣切りにならなくてすみそうです。
本当に助かりました。

今後の為にも、コードを勉強させて頂きます。
本当に有難うございました m(__)m

回答No.3

watabe007

A業務～C業務の何れかのセルを選択して実行してください。

Sub Test()
　　Dim myDic As Object
　　Dim Str As String
　　Dim d As Variant
　　Dim myc As Long, i As Long, j As Long

　　myc = ActiveCell.Column
　　If myc < 3 Or myc > 5 Then Exit Sub
　　Set myDic = CreateObject("Scripting.Dictionary")
　　For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
　　　　Str = Cells(i, myc).Value
　　　　If Not myDic.Exists(Str) Then
　　　　　　myDic(Str) = Cells(i, "B").Value
　　　　Else
　　　　　　myDic(Str) = myDic(Str) & "," & Cells(i, "B").Value
　　　　End If
　　Next
　　With Sheets("Sheet2")
　　　　For Each d In myDic.keys
　　　　　　j = j + 1
　　　　　　.Cells(j, "A").Value = d & "：" & myDic(d)
　　　　Next
　　End With
　　Set myDic = Nothing
End Sub

回答No.2

tom04

こんにちは！
外しているかもしれませんが・・・
Sheet2のA1に「to」
A2に「cc」
A3に「bcc」とすでに入っているとします。

＞もしも、A業務のセルををクリックしたら、、、
とありますが、「ダブルクリックすると」にしています。

Sheet1のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストして1行目項目をダブルクリックしてみてください。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i, j, k As Long
Dim ws As Worksheet
Dim buf As Variant
Set ws = Worksheets("Sheet2")
If Intersect(Target, Rows(1)) Is Nothing Or Target.Column < 3 Or _
Target = "" Or Selection.Count <> 1 Then Exit Sub
j = Target.Column
Cancel = True
ws.Columns(2).ClearContents
For k = 1 To ws.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, j) = ws.Cells(k, 1) Then
buf = buf & Cells(i, 2) & ","
End If
Next i
ws.Cells(k, 2) = Left(buf, Len(buf) - 1)
buf = ""
Next k
ws.Columns.AutoFit
ws.Activate
ws.Cells(1, 1).Select
End Sub

※　A・B列で分けていますが、こんな感じではどうでしょうか？m(__)m

お礼

素晴らしいです！！
本当にありがとうございます！！
理想どおりの回答を頂けて、感動してます☆。

今日も図書館で調べていたのですが、
わからなくて困っていた所でしたので
本当に助かりました。

今後の為にも、コードを勉強させて頂きます。
本当に有難うございました m(__)m

補足

再質問で申し訳ありませんm(__)m。

もしもSheet１において、　"to"　に該当する
データが存在しない場合、
Sheet2　の　to(A1)の右隣　B1は空白、
cc(A2) と bcc(A3) の右隣のB2とB3には、
該当するものが表示されて、
結果は正しいのですが、途中で、

『　実行時エラー'5':
　　プロシージャの呼び出し、または引数が不正です。　』
とブレイクされます。

途中でマクロが止まらないよう、応急処置として、今は

ws.Cells(k,2)=Left(buf,Len(buf)-1)　を

On Error Resume Next
On Error Goto 0
ではさんでいます。

もし、良い方法がありましたら、
教えて下さいますよう宜しくお願い致します。

回答No.1

LHS07

to　　　444@ddd
は表示しなくていいのですか？

お礼

to　の後には、111@aaa　と　444@ddd　をカンマで連ねて表示させたいのです。
そうゆう風に出来るものなのでしょうか？。
もし、おわかりでしたら、教えて下さいますよう宜しくお願い致します。