| |
▼しん さん：
こんばんは。
>とあるwebサイトの質問箱に
>
>A B
>1行燈 芥川10,鴎外157
>2囲炉裏 独歩31,谷崎55
>3囲炉裏 独歩96
>4鵜飼い鴎外26
>5お社鴎外17
>
>というテーブルがあって、これを
>
>A B
>1行燈 芥川10,鴎外157
>2囲炉裏 独歩31,96,谷崎55
>3鵜飼い鴎外26
>4お社鴎外17
>
>のように並び替えしたいという質問がありましたが、これなどもichinoseさんの魔術にかかれば簡単に解決できるのでしょうね！
簡単ではありませんよ！！
ただ、文字列解析と言うのは、最終的には一文字ずつチェックしていけば
何とかなりそうですよね？
上記の問題は、「おまけ」みたいなもののようですから、
一部だけ・・・。
この問題の入力データの２行目、３行目の「囲炉裏」のＢ列
「独歩31,谷崎55,独歩96」とまとめるのはガチャガチャ（←表現難しい？）
すれば何とかなりそうですよね・・・。
では、ここから、-----「独歩31,96,谷崎55」に加工するとこだけ。
これだったら、ここで投稿したプロシジャーを使えば何とかなるもので・・。
'====================================================================
Sub test()
Dim ans() As String
Dim sep1() As String
Dim sep2() As String
Dim ques_str As String
Dim moto_array() As String
Dim s_clct As Collection
ques_str = "独歩31,谷崎55,独歩96,独歩100,谷崎98" '入力データ
Call 文字列分解(ques_str, sep1(), "[0-9]+") '半角数字を取り出す
no_num = ques_str
For idx = LBound(sep1()) To UBound(sep1())
no_num = replace(no_num, sep1(idx), "") '数字のない文字列作成
Next
moto_array() = Split(ques_str, ",") '元データをカンマ分割
sep2() = Split(no_num, ",") '数字のないデータをカンマ分割
Set s_clct = mk_unique_collection(sep2()) '重複なし作成
kdx = 0
For idx = 1 To s_clct.Count
wk = Filter(moto_array(), s_clct.Item(idx))
For jdx = LBound(wk) To UBound(wk)
ReDim Preserve ans(1 To kdx + 1)
If jdx = LBound(wk) Then
ans(kdx + 1) = wk(jdx)
Else
ans(kdx + 1) = replace(wk(jdx), s_clct.Item(idx), "")
End If
kdx = kdx + 1
Next jdx
Next idx
If kdx > 0 Then
MsgBox Join(ans(), ",") '出力データ表示
End If
End Sub
'=================================================================
Sub 文字列分解(strng, a_array() As String, pat As String)
'文字列分解というプロシジャーをちょっと拡張しました
'（というより、私の元コレクションはこっち）
Dim regEx, Match, Matches ' 変数を作成します。
Set regEx = CreateObject("VBScript.RegExp")
' 正規表現を作成します。
regEx.Pattern = pat
regEx.IgnoreCase = True ' 大文字と小文字を区別しないように設定します。
regEx.Global = True ' 文字列全体を検索するように設定します。
Set Matches = regEx.Execute(strng) ' 検索を実行します。
idx = 1
For Each Match In Matches ' Matches コレクションに対して繰り返し処理を行います。
ReDim Preserve a_array(1 To idx)
a_array(idx) = Match.Value
idx = idx + 1
Next
Set regEx = Nothing
Set Match = Nothing
Set Matches = Nothing
End Sub
'=================================================================
Function mk_unique_collection(myarray() As String)
Dim myclct As New Collection
On Error Resume Next
For idx = LBound(myarray()) To UBound(myarray())
myclct.Add myarray(idx), myarray(idx)
Next
Set mk_unique_collection = myclct
Set myclct = Nothing
On Error GoTo 0
End Function
簡単なデータならＯＫだと思います。
Filter関数を使ってますから、また、漏れが心配だけど、
ダメならひとつづつチェックするしかないでしょうね！！
前半は、しんさん 考えてみて下さい。
|
|
ichinose
- 04/6/4(金) 18:21 -
