エクセルで項目名を指定せずに数を数える方法をおしえて下さい。

　　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ

１　いちご　りんご　ぶどう　めろん　　

２　りんご　みかん　めろん　いちご

３　みかん　いちご　みかん　みかん

４　すいか　　　　　いちご

と入っていて、

　　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ

11　いちご

12　みかん

13　めろん

14　りんご

15　すいか

16　ぶどう

といった形で、B列に個数を求めたい場合

B列にcountifという関数を埋め込めばできますよ。

例えば、B11の場合

=COUNTIF($A$1:$D$4,A11)

とすれば、いちごの数を数えてくれます。

$A$1:$D$4 がカウントする範囲の指定。

A11 がカウントする項目の条件の指定です。

B11に関数を埋め込んだら、あとは下のセルにコピーすれば数えられます。

また、A列の名称を変更すれば、自動的に数を数えなおしてくれますよ。

Sub Macro1()
    s1 = "Sheet1"   '対象があるシート
    s2 = "Sheet2"   '結果をのせるシート
    
    r1 = 1          '開始 行
    c1 = 1          '開始 列
    r2 = 4          '終了 行
    c2 = 4          '終了 列
    
    a = 0
    
    For b1 = r1 To r2
        For b2 = c1 To c2
            c = Worksheets(s1).Cells(b1, b2)
            If c <> "" Then
                f = 0
                For d = 1 To a
                    If Worksheets(s2).Cells(d, 2) = c Then
                        Worksheets(s2).Cells(d, 1) = Worksheets(s2).Cells(d, 1) + 1
                        f = 1
                        Exit For
                    End If
                Next d
                If f = 0 Then
                    a = a + 1
                    Worksheets(s2).Cells(a, 1) = 1
                    Worksheets(s2).Cells(a, 2) = c
                End If
            End If
        Next b2
    Next b1
    
    'ソートする。
    Worksheets(s2).Columns("A:B").Sort Key1:=Range("A1"), Order1:=xlDescending, Key2:=Range("B1"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal

End Sub

マクロを作ってみました。

変更箇所は

s1 = "Sheet1" '対象があるシート

s2 = "Sheet2" '結果をのせるシート

r1 = 1 '開始 行

c1 = 1 '開始 列

r2 = 4 '終了 行

c2 = 4 '終了 列

です。

集計は 別シートに出すようにしましたので、そのシート名と 表があるシート名を指定してください。

あと それぞれ行数と列数も 指定してください。

Nigitamaさんの言われてるDictionaryオブジェクト使ってみますと・・・

Sub UseDic()
    Dim s1, s2 As String
    Dim myDic As Object
    Dim myKey, myItem
    Dim v1, v2
    Dim i As Long
    
    s1 = "Sheet1"   '対象があるシート
    s2 = "Sheet2"   '結果をのせるシート
    
    '集計前の表を指定してください。
    v1 = Worksheets(s1).Range("A1:D4").Value
      
    Set myDic = CreateObject("Scripting.Dictionary")
        
    For Each v2 In v1
        If Not v2 = Empty Then
            If Not myDic.exists(v2) Then
                myDic.Add v2, 1
            Else
                myDic(v2) = myDic(v2) + 1
            End If
        End If
    Next
    
    myKey = myDic.Keys
    myItem = myDic.Items
    For i = 0 To UBound(myDic.Keys)
        Worksheets(s2).Cells(i + 1, 1).Value = myKey(i)
        Worksheets(s2).Cells(i + 1, 2).Value = myItem(i)
    Next
    
    'ソートは一緒
    
    Set myDic = Nothing
End Sub