Sub CreGraph()
Dim derlgn As Integer, I As Integer, M As Integer, L As Integer
Dim tabtemp As Variant
Dim TabResult()
Dim Mission As New Collection
With ActiveSheet
derlgn = .Range('F65536').End(xlUp).Row
tabtemp = .Range(.Cells(2, 6), .Cells(derlgn, 6)).value
For I = 1 To UBound(tabtemp, 1)
On Error Resume Next
Mission.Add tabtemp(I, 1), CStr(tabtemp(I, 1))
On Error GoTo 0
Next
ReDim TabResult(Mission.Count, 2)
For M = 1 To Mission.Count
TabResult(M, 1) = Mission(M)
Next
For M = 1 To Mission.Count
For L = 1 To UBound(tabtemp, 1)
If TabResult(M, 1) = tabtemp(L, 1) Then
TabResult(M, 2) = TabResult(M, 2) + 1
End If
Next
Next
For L = 1 To UBound(TabResult, 1)
.Cells(L + 1, 10) = TabResult(L, 1)
.Cells(L + 1, 11) = TabResult(L, 2)
Next
End With
End Sub