[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『小学校児童名簿から兄弟関係を抽出したい。』（nonvily）
A B C D E
学年 組 名前 電話 兄弟姉妹関係
1 1 浅利 友以乃 090- 986-5423
1 1 都築 なつみ 090-7835-4999
1 2 石原 さんま 090-5459-2057
1 2 手島 あき 080- 855-4072
1 3 浅見 康文 090-2212-9844
1 3 小久保 信吾 090-3903-1731
3 1 芹沢 憲一 080-9544-3223
3 1 稲垣 誠一 090-5820- 737
3 2 浅利 友恵 090- 986-5423
3 2 勝田 沙耶 080-6871-2920
3 3 石原 ヒロ 090-5459-2057
3 3 影山 慶太 080-6720-1807
3 3 三木 一輝 090-6185-8758
5 1 川添 満 090-3839- 980
5 1 寺本 一輝 090-4324-8613
5 2 坂田 優 080-4950-7610
5 2 中西 彩華 080-3910- 58
5 3 立花 孝太郎 080-3017-2366
5 3 松川 惇 080-2349-1071
5 2 石原 憲一 090-5459-2057
6 3 手島 登 080- 855-4072
上記のような項目の名簿（架空データ）から、同じ電話番号を手がかりに、兄弟姉妹欄を抽出（例：石原 さんま の行なら 3-3ヒロ,5-2憲一)する関数を組みたいのですが、できますか。兄弟姉妹がいない児童は空欄にしたいです。よろしくお願いします。
＜ 使用 Excel：Excel2013、使用 OS：Windows10 ＞
確認だけ。
1）兄弟姉妹が二人以上いるとき、一人目はE列、二人目はF列･･･というように列を分けてもいいのか？
2）作業列を使ってもいいのか？
3）実際の名簿は最大で何行ぐらいになるのか？
4）実際の名簿は、見出しが何行目で、データは何行目からなのか？
とりあえず以上です。 （笑） 2017/03/26(日) 13:20
＞１）E列に全て納めたいです。
ちょっと意外なお答え･･･。
では、確認ばかりで恐縮ですけど、
1）作業列を使ってもいいということは、いったんどこかに一人一列で抽出して、 そこから一列にまとめてもいいのか？ つまり、作業列を何列使っても、E列に全て納まってさえいればそれでオッケーなのか？
2）兄弟姉妹は、一番多い子で何人ぐらいをみておけばいいのか？ 六つ子が入学してくるかもしれない、みたいなことも想定する必要があるのか？
3）ＶＢＡでもいいのか？ それでもいいと宣言してもらうと、虎視眈々と狙っているＶＢＡの専門家さんが すぐさまアップを始めると思います。
とりあえず以上です。 （笑） 2017/03/26(日) 17:20
これを標準モジュールに貼り付け後、データシートをアクティブにして(←重要）、「siling」を実行する。 ↓
Enum pos
学年 = 1
組 = 2
名前 = 3
電話 = 4
兄弟姉妹関係 = 5
End Enum
Sub sibling()
Dim dicT As Object
Dim DTrng As Range, DTval, UnitStr, Itm, temp, RowN As Long
Set dicT = CreateObject("Scripting.Dictionary")
Set DTrng = Range("A3", Cells(Rows.Count, "C").End(xlUp).Offset(0, 2))
DTval = DTrng.Value
For RowN = 1 To UBound(DTval)
UnitStr = "、" & DTval(RowN, 学年) & "-" & DTval(RowN, 組) & " " & DTval(RowN, 名前)
dicT(DTval(RowN, 電話)) = dicT(DTval(RowN, 電話)) & UnitStr
Next RowN
For RowN = 1 To UBound(DTval)
Itm = dicT(DTval(RowN, 電話))
UnitStr = "、" & DTval(RowN, 学年) & "-" & DTval(RowN, 組) & " " & DTval(RowN, 名前)
temp = Replace(Replace(Itm, UnitStr, ""), Split(DTval(RowN, 名前), " ")(0) & " ", "")
If temp <> "" Then
DTval(RowN, 兄弟姉妹関係) = Right(temp, Len(temp) - 1)
End If
Next RowN
Range("E3:E1000").ClearContents
DTrng.Value = DTval
End Sub
<結果図> 行 __A__ _B_ _____C_____ ______D______ _________E_________ 1 2 学年 組 名前 電話 兄弟姉妹関係 3 1 1 浅利 友以乃 090-986-5423 3-2 友恵 4 1 1 都築 なつみ 090-7835-4999 5 1 2 石原 さんま 090-5459-2057 3-3 ヒロ、5-2 憲一 6 1 2 手島 あき 080-855-4072 6-3 登
: : : :
（半平太） 2017/03/26(日) 21:09
書きなぐっただけで、見直しをしていません。 もう少しスマートに組み立てられると思いますが、とりあえず。
Sub Sample()
Dim dic As Object
Dim ans As Object
Dim k As Variant
Dim c As Range
Dim tel As String
Dim nm As String
Set dic = CreateObject("Scripting.Dictionary")
Set ans = CreateObject("Scripting.Dictionary")
For Each c In Range("D2", Range("D" & Rows.Count).End(xlUp))
tel = c.Value
nm = c.Offset(, -1).Value
If Not dic.exists(tel) Then Set dic(tel) = CreateObject("Scripting.Dictionary")
dic(tel)(nm) = c.Offset(, -3).Value & "-" & c.Offset(, -2).Value & Split(c.Offset(, -1).Value)(1)
Next
For Each c In Range("C2", Range("C" & Rows.Count).End(xlUp))
ans.RemoveAll
nm = c.Value
tel = c.Offset(, 1).Value
For Each k In dic(tel)
If k <> nm Then ans(ans.Count) = dic(tel)(k)
Next
If ans.Count > 0 Then
c.Offset(, 2).Value = Join(ans.items, ",")
Else
c.Offset(, 2).ClearContents
End If
Next
End Sub
（ β） 2017/03/26(日) 21:48
>「インデックスが有効範囲にありません」
どのコードでエラーになりましたか？
それと、私のコードは C列の姓と名前の間が必ず半角スペースという決めつけをしていますが 実際のデータは、そうなっていますか？
（ β） 2017/03/27(月) 07:23
dic(tel)(nm) = c.Offset(, -3).Value & "-" & c.Offset(, -2).Value & Split(c.Offset(, -1).Value)(1)
それと、姓と名の間は全角スペースです。
よろししくお願いします。
（nonvily） 2017/03/27(月) 07:49
＞名字からフルネームで出てしまうんです。
区切り文字を半角と思ってしまったためです。 m(__)m ２か所全角にしてください。
↓ ↓ temp = Replace(Replace(Itm, UnitStr, ""), Split(DTval(RowN, 名前), " ")(0) & " ", "")
※姓を消去するのは最終段階で行っています。 兄弟姉妹でも、姓が違うケースが現実にあるのと、 電話番号を入力ミスして他の生徒と同じものを入れた場合、フルネームの方が発見し易いためです。
（半平太） 2017/03/27(月) 08:18
半平太さん同様、間を半角スペースにしていたためです。
dic(tel)(nm) = c.Offset(, -3).Value & "-" & c.Offset(, -2).Value & Split(c.Offset(, -1).Value)(1)
これを
dic(tel)(nm) = c.Offset(, -3).Value & "-" & c.Offset(, -2).Value & Split(c.Offset(, -1).Value, " ")(1)
に変更してください。
（β） 2017/03/27(月) 08:36
Dim c As Range, d As Range
Range("E:E").Cells.Clear
For Each c In Range("D:D").SpecialCells(xlCellTypeConstants)
For Each d In Range("D:D").SpecialCells(xlCellTypeConstants)
If c.Value = d.Value And c.Row <> d.Row Then
c.Offset(, 1).Value = IIf(Not c.Offset(, 1).Value = Empty, c.Offset(, 1).Value & ",", "") & d.Offset(, -3).Value & Space(1) & d.Offset(, -2).Value & Space(1) & IIf(InStr(StrConv(d.Offset(, -1).Value, vbWide), " "), Split(StrConv(d.Offset(, -1).Value, vbWide), " ")(1), "")
End If
Next d
Next c
End Sub
（mm） 2017/03/27(月) 13:41
関数でやってみました F列を作業用列とします
F3=","&A3&"-"&B3&MID(C3,FIND(" ",C3)+1,5)&IFERROR(INDEX(F4:$F$600,MATCH(D3,D4:$D$600,0)),"")
といれ 最終行までコピー
(FIND(" ",C3)+1,5)・・・の5は 名前の文字数が5文字以上が想定される場合最大値以上に変更して下さい)
E3=MID(SUBSTITUTE(INDEX($F$1:F3,MATCH(D3,$D$1:D3,0)),","&A3&"-"&B3&MID(C3,FIND(" ",C3)+1,5),""),2,100)
といれ 最終行までコピー
(最後の100は E列の想定最大文字数以上にして下さい)
（????） 2017/03/27(月) 18:57
実は実際の項目は
No.,学年、組、男女、氏名、ふりがな、生年月日、保護者、保護者、番号、部団名、住所、兄弟姉妹、電話
となります。
こちらで応用をきかしてと甘く考えていたのが間違いでした。列を移動して、コードを実行して兄弟姉妹を抽出してから、また列を戻すことにします。ありがとうございました。
（nonvily） 2017/03/27(月) 21:25
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.