excelでの条件抽出がうまくいきません

質問

excel2003を使用しております。条件抽出みたいなことをしたいのですが、うまくいきません。
　　　Ａ　 Ｂ　 Ｃ
1 　6/1 　北 　山本
2 　6/1 　西 　岡本
3 6/1 東 田村
4 6/1 北 長井
5 6/1 西 井出
6 6/2 北 田中
7 6/2 西 山本
8 6/2 西 田村
9 6/2 東 小池
10 6/2 南 松本
上記のようなデータがあります。
違う、シートに
6/1　北　山本・長井
6/1　西　岡本・井出
6/1　東　田村
6/2　北　田中
6/2　西　山本・田村
6/2 東 小池
6/2 南 松本
このようにまとめたいのですが、うまくいきません。ご教授宜しくお願いいたします。

回答No.2

pkh4989 · ベストアンサー

No1 です。
数式では無理がありますので、マクロにしました。
マクロも配列を利用しないと大変なので、配列を利用しました。
処理方法としては、日付・方位が違ったら配列に追加して設定しながら、同じ日付・方位がある時は
名前を結合するような処理です。
少し勉強すれば、そんなに難しくありませんので、頑張ってください。

お礼

少し勉強すれば出来ました！有難う御座います！
苦手なことから逃げていました・・・
まだ理解できていない部分がほとんどですが・・・・
何事もやってみることですね！
また、機会がありましたら宜しくお願いいたします。

回答No.1

pkh4989

こんにちは。

以下のマクロでお試しください。
<マクロ貼付方法>
Alt+F11 (ツール → マクロ → Visual Basic Editor) →「挿入」→「標準モジュール」で表示される画面に貼り付け
実行は、(F5を押す)又は、シート画面に戻って Alt＋F8を押してマクロ一覧からマクロ名を選択して実行

Const MxCOL　　 As Integer = 256
Type wRC
　　DATE　　　　As String
　　KBN　　　　 As String
　　NM(MxCOL) As String
End Type
Dim wDT()　　 As wRC
Dim wDTcnt　　 As Integer
'
Sub データ抽出()
　　Dim wI　　　　 As Long
　　Dim wY　　　　 As Long
　　Dim wR　　　　 As Long
　　Dim ckDT　　　　As String
　　Dim fFlg　　　　As Boolean
　　Dim fIdx　　　　As Integer
　　'
　　Application.ScreenUpdating = False
　　ckDT = ""
　　Erase wDT
　　wDTcnt = 0
　　With ActiveSheet　　　　'抽出元のデータシートをActiveにしてください
　　　　wR = .Range("A" & Rows.Count).End(xlUp).Row
　　　　For Each c In .Range("A1:A" & wR)
　　　　　　If ckDT = "" Then
　　　　　　　　wDTcnt = wDTcnt + 1
　　　　　　　　ReDim Preserve wDT(wDTcnt)
　　　　　　　　'
　　　　　　　　ckDT = c.Value & c.Offset(0, 1)
　　　　　　　　wDT(wDTcnt).DATE = c.Value　　　　　　　　 'A列(日付)
　　　　　　　　wDT(wDTcnt).KBN = c.Offset(0, 1)　　　　　　'B列(方向)
　　　　　　　　wDT(wDTcnt).NM(1) = c.Offset(0, 2)　　　　 'C列(名前)
　　　　　　Else
　　　　　　　　fFlg = False
　　　　　　　　For wI = 1 To wDTcnt
　　　　　　　　　　If wDT(wI).DATE = c.Value And _
　　　　　　　　　　 wDT(wI).KBN = c.Offset(0, 1) Then
　　　　　　　　　　 fIdx = wI
　　　　　　　　　　 fFlg = True
　　　　　　　　　　 Exit For
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　　　If fFlg = False Then
　　　　　　　　　　wDTcnt = wDTcnt + 1
　　　　　　　　　　ReDim Preserve wDT(wDTcnt)
　　　　　　　　　　'
　　　　　　　　　　ckDT = c.Value & c.Offset(0, 1)　　　　 'A列(日付)
　　　　　　　　　　wDT(wDTcnt).DATE = c.Value　　　　　　 'B列(方向)
　　　　　　　　　　wDT(wDTcnt).KBN = c.Offset(0, 1)　　　　'C列(名前)
　　　　　　　　　　fIdx = wDTcnt
　　　　　　　　End If
　　　　　　　　For wY = 1 To MxCOL
　　　　　　　　　　If wDT(fIdx).NM(wY) = "" Then
　　　　　　　　　　　　wDT(fIdx).NM(wY) = c.Offset(0, 2) 'C列(名前)
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　End If
　　　　Next
　　End With
　　'
　　'シート(Sheet2)へ展開します
　　With Worksheets("Sheet2")
　　　　.Cells.ClearContents
　　　　For wI = 1 To wDTcnt
　　　　　　.Cells(wI, 1) = wDT(wI).DATE　　　　　　　　　　'日付
　　　　　　.Cells(wI, 2) = wDT(wI).KBN　　　　　　　　　　 '方向
　　　　　　For wY = 1 To MxCOL　　　　　　　　　　　　　　 '名前
　　　　　　　　If wDT(wI).NM(wY) = "" Then
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　　　If wY = 1 Then
　　　　　　　　　　.Cells(wI, 3) = wDT(wI).NM(wY)
　　　　　　　　Else
　　　　　　　　　　.Cells(wI, 3) = .Cells(wI, 3) & "・" & wDT(wI).NM(wY)
　　　　　　　　End If
　　　　　　Next
　　　　Next
　　End With
　　Application.ScreenUpdating = True
End Sub

お礼

早速のご回答有難う御座います。試してみたところ、うまくいきました！有難う御座います。しかしながら、これをもとにいろいろカスタマイズしようと考えていたのですが、私には高度すぎてどこをどういじればよいのかわかりませんでした。エクセルの関数、数式で処理できるようにするにはやはり無理があるのでしょうか？せっかく教えていただいたのにすみません。