条件にあった複数データを組合わせて別のセルに表示するには？

質問

例えば、以下のデータがセルに入っていたとして

A列には姓　B列には名
A1:鈴木　　B1:一郎
A2:鈴木　　B2：次郎
A3:鈴木　　B3：三郎
A4:佐藤　　B3：あきら
A5:佐藤　　B3：けんた

同じ姓にあてはまるデータの名を、組合わせて別のセルに表示したいのです。

結果イメージ
C1:鈴木　　D1:一郎 次郎　三郎
C2:佐藤　　D2:あきら　けんた

このようなことAccessかExcelで出来ますか？

回答No.4

kazuhiko5681 · ベストアンサー

こんばんわ。修正マクロを作ってみました。前回の要領で実行してみて下さい。

Dim myAdr As String
Dim myCell As Range
Dim myVlu As String

If Target.Column <> 2 Then Exit Sub
myAdr = Range("A1:" & Cells(Rows.Count, 1).End(xlUp).Address).Address
Application.EnableEvents = False
If Range("C1").Value = "" Then
Range("C1").Value = Target.Offset(0, -1).Value
Range("D1").Value = Target.Value
Else
myAdr = Range("C1:" & Cells(Rows.Count, 3).End(xlUp).Address).Address
Set myCell = Range(myAdr).Find(Target.Offset(0, -1).Value, lookat:=xlWhole)
If myCell Is Nothing Then
Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Value = Target.Offset(0, -1).Value
Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Value = Target.Value
Else
myVlu = myCell.Offset(0, 1).Value
myCell.Offset(0, 1).Value = myVlu & " " & Target.Value
myCell.Offset(0, 1).EntireColumn.AutoFit
End If
End If

Application.EnableEvents = True

これであなた様の思い通りの操作になったかと思います。

お礼

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

回答No.3

imogasi

Sub test01()
l = Range("a1").CurrentRegion.Rows.Count
tl = 1 ' 名前集約の最終行
For i = 1 To l 'l　名前の最終行
For j = 1 To tl 'tl 名前集約の現在の最終行
If Cells(i, 1) = Cells(j, 3) Then
'--見つかれば名前を連ねる
Cells(j, 4) = Cells(j, 4) & " " & Cells(i, 2)
GoTo p01
Else
End If
Next j
Cells(tl, 3) = Cells(i, 1) 　'新顔の苗字をセット
Cells(tl, 4) = Cells(i, 2) '新顔の名前をセット　
tl = tl + 1
p01:
Next i
End Sub

お礼

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

回答No.2

nishi6

修正のことを考えて、マクロを実行することにより、全てを書き換えるようにしてみました。
シートのコードウインドウに貼り付けます。(Excel97です)

マクロより算式を使ったほうが面白い質問のように思えますが・・・複雑で、長くなりすぎた！

Sub Ketugou()
　　Dim rw1 As Long '読み込み行カウンタ
　　Dim rw3 As Long '書き出し行カウンタ(姓)
　　Dim rw4 As Long '書き出し行カウンタ(名)
　　Dim oldName As String '前のデータの名前
　　Dim KetugoNM As String '結合した名前

　　Range("C:D").ClearContents
　　With Range("A1")
　　　　'姓を取り出す
　　　　While .Offset(rw1, 0) <> ""
　　　　　　If .Offset(rw1, 0) <> oldName Then
　　　　　　　　.Offset(rw3, 2) = .Offset(rw1, 0): rw3 = rw3 + 1
　　　　　　　　oldName = .Offset(rw1, 0)
　　　　　　End If

　　　　　　rw1 = rw1 + 1
　　　　Wend
　　　　'名を取り出す
　　　　rw1 = 0
　　　　For rw4 = 0 To rw3 - 1
　　　　　　While .Offset(rw4, 2) = .Offset(rw1, 0)
　　　　　　　　KetugoNM = KetugoNM & " " & .Offset(rw1, 1)
　　　　　　　　rw1 = rw1 + 1
　　　　　　Wend
　　　　　　.Offset(rw4, 3) = Mid(KetugoNM, 2)
　　　　　　KetugoNM = ""
　　　　Next
　　End With
End Sub

お礼

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

回答No.1

kazuhiko5681

初めまして。サンプルマクロを作ってみました。これを下記の要領でコピー・ペーストすれば、何もすることなく自動であなた様のおやりになりたいことが実現できると思います。

１.新規ブックを開き、ＡＬＴ＋Ｆ１１キーを押してＶＢＥ画面を開く
２.画面左上のVBAProject徒書いてある下のSheet1をダブルクリックし、右側の白い部分へ上のコードをコピー・ペーストする。
３.ＡＬＴ＋Ｆ１１キーを押してエクセルの画面にもどり、シート１のＡ１・Ａ２に適当な値を入力する

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myAdr As String
Dim myRange As Range
Dim myCell As Range

If Target.Column <> 2 Then Exit Sub
myAdr = Range("A1:" & Cells(Rows.Count, 1).End(xlUp).Address).Address
Application.EnableEvents = False
If Range("C1").Value = "" Then
Range("C1").Value = Target.Offset(0, -1).Value
Range("D1").Value = Target.Value
Else
myAdr = Range("C1:" & Cells(Rows.Count, 3).End(xlUp).Address).Address
Set myCell = Range(myAdr).Find(Target.Offset(0, -1).Value, lookat:=xlWhole)
If myCell Is Nothing Then
Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).Value = Target.Offset(0, -1).Value
Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Value = Target.Value
Else
myCell.End(xlToRight).Offset(0, 1).Value = Target.Value
End If
End If

Application.EnableEvents = True

End Sub

もし不都合なことがありましたら、ご遠慮なくお知らせ下さい。あなた様のおやりになりたいことが実現するまで私でよろしければご一緒に考えてみたいと思います。

補足

kazuhiko5681さん、ご回答ありがとうございます！！
ところで、実行結果を１つのセルに表示させることはできますか？
例えば、D1にB1とB2とB3に入っているデータ（今回で言えば一郎　次郎　三郎）をくっつけて表示したいんです。。