| 
    
     |  | ▼hatena さん: こんにちは。
 
 >(A列に)より順次下記のようにデータが入ってます。
 >3◎
 >3×
 >3×
 >3×
 >2◎
 >2×
 
 標準モジュールに
 '==========================================================
 Sub main()
 Dim dic As Object
 Dim crng As Range
 Dim rng As Range
 Dim cnt As Long
 Set rng = Range("a1", Cells(Rows.Count, 1).End(xlUp))
 Set dic = CreateObject("scripting.dictionary")
 With dic
 For Each crng In rng
 If .Exists(CStr(crng.Value)) Then
 .Item(CStr(crng.Value)) = .Item(CStr(crng.Value)) + 1
 Else
 .Add CStr(crng.Value), 1
 End If
 Next
 Range(Cells(rng.Count + 2, 1), Cells(rng.Count + 1 + .Count, 1)).Value = Application.Transpose(.Keys)
 Range(Cells(rng.Count + 2, 2), Cells(rng.Count + 1 + .Count, 2)).Value = Application.Transpose(.Items)
 End With
 Set dic = Nothing
 End Sub
 
 
 >このカウント方法について教えてください。
 >尚値は固定ではないので、毎回セルから値をとって、その数を数えたいです。
 >っで最終行に
 >3◎-1個
 >3×-3個...と書かせたい
 >
 >
 >また応用として
 >
 >(A列に) (B)
 >3◎    3
 >3×    2
 >3×    2
 >3×    1
 >2◎    1
 >2×    1
 >同じく最終行に
 >3◎-3の数1個
 >3×-2の数2個
 >3×-1の数1個
 
 標準モジュールに
 '===============================================================
 Sub main2()
 Dim dic As Object
 Dim crng As Range
 Dim rng As Range
 Dim cnt As Long
 Set rng = Range("a1", Cells(Rows.Count, 1).End(xlUp))
 Set dic = CreateObject("scripting.dictionary")
 With dic
 For Each crng In rng
 If .Exists(CStr(crng.Value & "-" & crng.Offset(0, 1).Value)) Then
 .Item(CStr(crng.Value & "-" & crng.Offset(0, 1).Value)) = .Item(CStr(crng.Value & "-" & crng.Offset(0, 1).Value)) + 1
 Else
 .Add CStr(crng.Value & "-" & crng.Offset(0, 1).Value), 1
 End If
 Next
 Range(Cells(rng.Count + 2, 1), Cells(rng.Count + 1 + .Count, 1)).Value = Application.Transpose(.Keys)
 Range(Cells(rng.Count + 2, 2), Cells(rng.Count + 1 + .Count, 2)).Value = Application.Transpose(.Items)
 End With
 Set dic = Nothing
 End Sub
 
 
 いづれも対象シートをアクティブにして実行してみて下さい
 
 |  |