| |
こんにちは〜
Try2()方式で、
シートに書き出すようにしてみました。
Hirofumiさんが E,F列に書き出してらっしゃいますので、
こちらは [G2]以降に出力です。
Sub Try2c()
Dim dic As Object
Dim r As Range
Dim i As Long
Dim j As Long, jx As Long
Dim ss As String
Dim zz As String
Set dic = CreateObject("Scripting.Dictionary")
Set r = Range("A1").CurrentRegion
Set r = Intersect(r, r.Offset(1)) '1行目を削除
jx = r.Columns.Count
For j = 1 To jx '最終列まで繰り返し
For i = 1 To r.Rows.Count 'j列を最終行まで繰り返し
ss = r(i, j).Value
If Len(ss) > 0 Then '行数が列によって異なることがある
If Not dic.Exists(ss) Then
zz = Space$(jx) '列数分のスペースを準備
Else
zz = dic(ss) '辞書内の現在の文字列
End If
Mid(zz, j, 1) = "●" 'j桁目に●を書き込む
dic(ss) = zz
End If
Next
Next
'連続する●をカウントする
Dim key
Dim k As Long, ok As Boolean
For Each key In dic.Keys()
ss = dic(key)
ok = False
For k = Len(ss) To 2 Step -1
If InStr(ss, String$(k, "●")) Then
dic(key) = k
ok = True
Exit For
End If
Next
If Not ok Then dic.Remove key '辞書から削除
Next
'結果をシートに書き出す
[G2].Resize(dic.Count, 2).Value = _
Application.Transpose(Array(dic.Keys(), dic.Items()))
End Sub
|
|
kanabun
- 11/12/7(水) 10:45 -
