| |
簡単と言いましたけど、ちょっと書いてみたらこんなに長くなっちゃった Orz
Sub Try2()
Dim dic As Object
Dim r As Range
Dim i As Long
Dim j As Long, jj 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行目を削除
jj = r.Columns.Count
For j = 1 To jj '最終列まで繰り返し
For i = 1 To r.Rows.Count
ss = r(i, j).Value
If Len(ss) > 0 Then
If Not dic.Exists(ss) Then'初めてのアイテムのとき
zz = Space$(jj) '列数分のスペース
Else
zz = dic(ss) '既出アイテムのとき
End If
Mid(zz, j, 1) = "●" 'j列目に●を書き込む
dic(ss) = zz
End If
Next
Next
Dim key
Dim k As Long
For Each key In dic.Keys()
zz = dic(key)
j = InStr(zz, "●●")
If j > 0 Then
k = 2
For i = j + 2 To Len(zz)
If Mid$(zz, i, 1) = "●" Then
k = k + 1
Else
Exit For
End If
Next
Debug.Print key, k
End If
Next
End Sub
'●●が含まれているアイテムだけとりだし、
りんご ●●● ←3列ともある
ごりら ●● ←どこか2列連続してある
らっぱ ●●● ←3列ともある
連続する●の数を数えます
りんご 3
ごりら 2
らっぱ 3
|
|
kanabun
- 11/12/6(火) 19:50 -
