重複名を１つにまとめ 他のセルと関連付けたい

A 　　　　　B 　　　　　 C
1 山田　　　テレビ　　　パナソニック
2 山田　　　洗濯機 　　　三菱
3 山田　　　冷蔵庫 　　　パナソニック
4 佐藤　　　テレビ 　ソニー
5 佐藤　　　冷蔵庫　　　三菱
6 佐藤　　　パソコン　　富士通
7 鈴木　　　テレビ　　　シャープ
8 鈴木　　　エアコン　　三菱

　　　↓↓↓　

　　 A 　　　　　 B 　　　　 C 　　　 　 D 　　　　 E 　　　　 F 　　　 G
1 山田　　テレビ　パナソニック　洗濯機　三菱　冷蔵庫　パナソニック　
2 佐藤　　テレビ　　ソニー　　　冷蔵庫　三菱　パソコン　富士通
3 鈴木　　テレビ　　シャープ　 エアコン 　三菱

上記のようにしたいのですが、ご教授よろしくお願いします。

No.3 ベストアンサー 回答者： tom04 回答日時： 2016/05/17 08:52

No.2です。

＞元データがK列まで対応できるように出来ますか

K列に限定せず、その行のデータがある最終列までとしてみました。
前回のコードは消去し、↓のコードにしてみてください。

Sub Sample2()
Dim i As Long, k As Long, lastCol As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
wS.Cells.Clear
With Worksheets("Sheet1")
.Rows(1).Insert
.Range("A1") = "ダミー"
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
For k = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(k, "A") = wS.Cells(i, "A") Then
lastCol = .Cells(k, Columns.Count).End(xlToLeft).Column
Range(.Cells(k, "B"), .Cells(k, lastCol)).Copy wS.Cells(i, Columns.Count).End(xlToLeft).Offset(, 1)
End If
Next k
Next i
wS.Columns.AutoFit
wS.Rows(1).Delete
.Rows(1).Delete
wS.Activate
End With
Application.ScreenUpdating = True
End Sub

※　K列までと決まっているのであれば、
最初にある変数の宣言の
lastCol As Long
を消し（カンマも一つ消します）

＞lastCol = .Cells(k, Columns.Count).End(xlToLeft).Column
＞Range(.Cells(k, "B"), .Cells(k, lastCol)).Copy wS.Cells(i, Columns.Count).End(xlToLeft).Offset(, 1)

の2行を
＞Range(.Cells(k, "B"), .Cells(k, "K")).Copy wS.Cells(i, Columns.Count).End(xlToLeft).Offset(, 1)
としてみてください。m(_ _)m

この回答へのお礼

たいへんお世話になりました。
また、解らないことがあった時にはよろしくお願いします。

お礼日時：2016/05/17 18:06

No.2 回答者： tom04 回答日時： 2016/05/16 21:50

こんばんは！

VBAになりますが、一例です。
データは1行目からあるのですね？
（1行目は項目行で2行目以降にデータがある場合が一般的だと思うのですが）

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

Sub Sample1() 'この行から//
Dim i As Long, k As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
wS.Cells.Clear
With Worksheets("Sheet1")
.Rows(1).Insert
.Range("A1") = "ダミー"
.Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
For k = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(k, "A") = wS.Cells(i, "A") Then
.Cells(k, "B").Resize(, 2).Copy wS.Cells(i, Columns.Count).End(xlToLeft).Offset(, 1)
End If
Next k
Next i
wS.Rows(1).Delete
wS.Columns.AutoFit
.Rows(1).Delete
wS.Activate
End With
End Sub 'この行まで//

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

この回答へのお礼

tom04さま
ありがとうございます。
ほとんど私のしたいことになっていましたが
私の質問では元データA,Bの２列まででしたが
すみませんがあとできれば元データがK列まで対応できるように出来ますか
よろしくお願いします。

お礼日時：2016/05/16 22:44

No.1 回答者： hallo-2007 回答日時： 2016/05/16 20:46

一行目が項目として、2行目のB,Cセル

B２セルに
=IF(COLUMN(A1)/2>COUNTIF(Sheet1!$A:$A,$A2),"",INDEX(Sheet1!$B:$B,MATCH($A2,Sheet1!$A:$A,FALSE)+COLUMN(A1)/2-0.5))
C２セルに
=IF(COLUMN(A1)/2>COUNTIF(Sheet1!$A:$A,$A2),"",INDEX(Sheet1!$C:$C,MATCH($A2,Sheet1!$A:$A,FALSE)+COLUMN(A1)/2-0.5))
B1～C1の範囲を右へコピー、下へコピーしてみて下さい。

この回答へのお礼

hallo-2007さん
ありがとうございます。
ほとんど私のしたいことになっていましたが。
すみませんがあとできれば元データがK列まで対応できるように出来ますか
また、A列の名前もsheet2に自動転記できないですか？
よろしくお願いします。

お礼日時：2016/05/16 22:44