VBAでのカウント方法

質問

例えば
A
A
A
B
C
B
A

とならんでいる式を各文字ごとにカウントして

A 4
B 2
C 1

と表示するにはどのようなマクロを組んだらよろしいのでしょうか？
困ってます！
お願いします＞＜

回答No.4

zuku

いろいろ解法はあると思いますが、VBAのみで処理する
としたらこんな感じでどうでしょうか。
参考になれば幸いです。

Type StrCount
Name As String
Count As Integer
End Type
Private Counts() As StrCount ' 結果を格納する配列

Public Sub Main()
Dim data() As String
Dim i As Integer
Dim idx As Integer

' 初期データ
data = Split("A,A,A,B,C,B,A", ",")

' 一番目の要素
ReDim Counts(1 To 1) As StrCount
Counts(1).Name = data(LBound(data))
Counts(1).Count = 1

' 二番目以降の要素
For i = LBound(data) + 1 To UBound(data)
idx = findStr(data(i))
If idx < LBound(Counts) Then
ReDim Preserve Counts(1 To UBound(Counts) + 1) As StrCount
Counts(UBound(Counts)).Name = data(i)
Counts(UBound(Counts)).Count = 1
Else
Counts(idx).Count = Counts(idx).Count + 1
End If
Next

' 結果の表示
For i = LBound(Counts) To UBound(Counts)
Debug.Print Counts(i).Name & " " & Counts(i).Count
Next
End Sub
' 文字検索
Public Function findStr(s As String) As Integer
Dim idx As Integer

findStr = -1
For idx = LBound(Counts) To UBound(Counts)
If Counts(idx).Name = s Then
findStr = idx
Exit For
End If
Next
End Function

＃空配列の認識方法が分らなかったので
＃お世辞にもスマートとは言えませんが・・・

回答No.3

Wendy02

こんばんは。

あまりセル位置のキメウチは、コードとしてはふさわしくないような気がしますが、サンプルとしてお許しください。

この手のものは、VBA掲示板ではFAQです。本来は、２次元配列で、一気に出力するというのが定番の解答なのですが、こちらの掲示板では、このようなフィルタオプションで解くのが、もっともシンプルのような気がしております。

つまり早い話、フィルタオプションとCOUNTIF の記録マクロで簡単に出来るということです。

'<標準モジュール>
Sub AdvancedFilterUsedCounting()
Dim r As Range
　　Application.ScreenUpdating = False
　　'タイトル行がある場合は、次の１行は不要
　　Range("A1").Insert:　 Range("A1").Value = "Dum"
　　Range("C1").ClearContents
　　Set r = Range("A1", Range("A1").End(xlDown))
　　　　 r.AdvancedFilter _
　　　　 Action:=xlFilterCopy, _
　　　　 CopyToRange:=Range("C1"), Unique:=True
　　With Range("C2", Range("C2").End(xlDown)).Offset(, 1)
　　　 .FormulaLocal = "=COUNTIF(" & r.Address(, , xlR1C1) & ",RC[-1])"
　　　 .Value = .Value
　　End With
　　'タイトル行がある場合は、次の１行は不要
　 Range("A1").Delete: Range("C1:D1").Delete
　 Set r = Nothing
　 Application.ScreenUpdating = True
End Sub

回答No.2

imogasi

データについて同じ箱がないか調べ、あれば＋１件する。
なければ新しい内容が現れたとして「箱」を増やし１をセットする。
終わりまで繰り返し。
「投げ入れ法」。社内各部に、年賀状仕分け箱（棚）のイメージ。
Sub test01()
j = 1
Cells(j, "D") = 1
Cells(j, "C") = Cells(1, "A")
'------
d = Range("A65536").End(xlUp).Row
MsgBox d
For i = 2 To d
For k = 1 To j
If Cells(i, "A") = Cells(k, "C") Then
Cells(k, "D") = Cells(k, "D") + 1
GoTo p1
End If
Next k
j = j + 1
Cells(j, "C") = Cells(i, "A")
Cells(j, "D") = 1
p1:
Next i
End Sub
エクセルでやりましたが、セルを使わないなら、セルを配列で置き換えて考えてください。
C1:D3に答え
A 4
B 2
C 1
学がすすんだら、Findメソッドなどを使って、上記総舐める的なロジックを
改良する手もある。

回答No.1

ASIMOV

Sub TEST()
Dim a, b, c As Double
For Each mycell In Range("A1:A7") 'A列に有るとして
Select Case mycell.Value
Case "A"
a = a + 1
Case "B"
b = b + 1
Case "C"
c = c + 1
End Select
Next
MsgBox "A=" & a & " B=" & b & " C=" & c '出力はセルに書き込んでも良いですね
End Sub

お礼

どうもありがとうございます！
a,b,cが既知のものではないので今回は使えないっぽいっす。
けど、いろんなやり方があるのだと感じました。