|
▼じゅんじゅん さん:
>▼Nishimura さん:
>>▼ichinose さん:
>Sub try()
> Dim Dic As Object
> Dim r As Range
> Dim v, key
> Dim i As Long
>
> Set Dic = CreateObject("Scripting.Dictionary")
>
> With ActiveSheet
> v = .Range(.Range("I8"), .Cells(Rows.Count, "I").End(xlUp))
>
> For i = 1 To UBound(v, 1)
> If Not Dic.exists(v(i, 1)) Then
> Dic(v(i, 1)) = Array(i + 7, i + 7)
> Else
> Dic(v(i, 1)) = Array(Dic(v(i, 1))(0), i + 7)
> End If
> Next
>
> For i = 1 To UBound(v, 1)
> For Each key In Dic.keys
> If v(i, 1) <> key Then
> Set r = .Range("I" & Dic(key)(0), "I" & Dic(key)(1))
> If Not Intersect(.Range("I" & i + 7), r) Is Nothing Then
> .Range("J" & i + 7).Value = _
> WorksheetFunction.CountIf(r, v(i, 1))
> End If
> End If
> Next
> Next
> Set Dic = Nothing
> Set r = Nothing
> End With
>
>無駄な作業もあるかと思いますが、ご参考になれば幸いです。
ごめんなさい。
End With の後ろに
End Sub が抜けてました。
|
|