| |
▼(m´・ω・｀)m さん：
皆さんと同じく、２つ以上連続しているもののみ列挙のバージョンです。
Sub Sample2()
Dim x As Long
Dim y As Long
Dim z As Long
Dim i As Long
Dim j As Long
Dim c As Range
Dim r As Range
Dim dic As Object
Dim dk As Variant
Dim s As String
Dim f As String
Dim v() As Variant
Set dic = CreateObject("Scripting.Dictionary")
With ActiveSheet.UsedRange
x = .Columns.Count
y = .Rows.Count
Set r = .Cells.Offset(1).Resize(.Rows.Count - 1)
End With
For Each c In r
dk = c.Value
If Len(dk) > 0 Then
If Not dic.Exists(dk) Then
s = Empty
For j = 1 To x
f = " "
If IsNumeric(Application.Match(dk, Columns(j), 0)) Then f = "●"
s = s & f
Next
dic(dk) = s
End If
End If
Next
ReDim v(1 To dic.Count, 1 To 2)
For Each dk In dic
For j = x To 2 Step -1
z = InStr(dic(dk), WorksheetFunction.Rept("●", j))
If z > 0 Then Exit For
Next
If j > 1 Then
i = i + 1
v(i, 1) = dk
v(i, 2) = j
End If
Next
Cells(1, x + 2).Resize(UBound(v, 1), 2).Value = v
Set dic = Nothing
Set r = Nothing
End Sub
|
|
UO3
- 11/12/10(土) 16:41 -
