| |
▼ichinose さん：
こんばんは、しんです。
さっそくおまけのVBAコードまで教えて頂きありがとうございました。
さすがichinoseさんは相変わらず凄いですね。
ところで
>前半は、しんさん 考えてみて下さい。
ということなので、あちこち重複データ処理法を参考にして、ichinoseさんのコードとドッキングした結果、下記コード
'Option Explicit
Public i, j, k, NumberOfData
'====================================================================
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
Call DeleteDuplicates(NumberOfData)
'ques_str = "独歩31,谷崎55,独歩96,独歩100,谷崎98" '入力データ
For k = 1 To NumberOfData
ques_str = Cells(k, 2).Value
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(), ",") '出力データ表示
Cells(k, 5) = Join(ans(), ",") '出力データ表示
End If
Next k
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
'=========重複行の削除と文字列の結合=================================
Sub DeleteDuplicates(NumberOfData)
Sheets("Sheet1").Activate
NumberOfData = Application.CountA(ActiveSheet.Range("A:A"))
For j = 1 To 6
i = 2
Do While i <= NumberOfData
If Cells(i, 1) = Cells(i - 1, 1) Then
Rows(i).Select
Cells(i - 1, 2).Value = Cells(i - 1, 2).Value & "," & Cells(i, 2).Value
Selection.Delete Shift:=xlUp
NumberOfData = NumberOfData - 1
End If
i = i + 1
Loop
Next
End Sub
により、題意のデータ列
A B
行燈 芥川10,鴎外157
囲炉裏 独歩31,谷崎55
囲炉裏 独歩100
囲炉裏 独歩96
鵜飼い 鴎外26
お社 鴎外17,谷崎51
は、次のように変換することができました。題意のデータ列はA列であらかじめソートしておく必要はありますが・・・。
A B E
行燈 芥川10,鴎外157 芥川10,鴎外157
囲炉裏 独歩31,谷崎55,独歩100,独歩96 独歩31,100,96,谷崎55
鵜飼い 鴎外26 鴎外26
お社 鴎外17,谷崎51 鴎外17,谷崎51
ichinoseさんのおかげで大変勉強になりました。これからもこれに懲りずまたいろいろ教えて頂けることを祈っております。どうかよろしくお願い致します。
|
|
しん
- 04/6/5(土) 2:52 -
