範囲内で同一セルの最大の個数の求め方（マクロ）

質問

たとえば配列数式で

{=MAX(COUNTIF($B$2:$B$100,B2:B100))}

のように範囲内で同一セルの最大個数を求めるのをＶＢＡマクロでやりたいのです。
どのような記述になるのでしょうか？

回答No.4

ja7awu · ベストアンサー

そういうことなら、次のコードで如何でしょうか。

Sub 最大個数()
Dim Rng As Range
Dim MaxVal As String
Dim MaxCount As Long
With Application.WorksheetFunction
　　For Each Rng In Range("B2:B100")
　　　　If MaxCount < .CountIf(Range("B2:B100"), Rng.Value) Then
　　　　　　MaxVal = Rng.Value
　　　　　　MaxCount = .CountIf(Range("B2:B100"), Rng.Value)
　　　　End If
　　Next Rng
End With
MsgBox "最大は、 " & MaxVal & " の " & MaxCount & " 個です。"
End Sub

※ 提示の配列式では、「何々が何個」という形では出ないと思いますが・・・

お礼

ありがとうございました！
もうばっちりです。
とても助かりました。

回答No.3

imogasi

ある列で（Ｂ列）同一内容のセルをカウントし、その中で
一番多い件数を求める。
Ｃ列をワークに使います。
Sub test02()
d = Range("b2").CurrentRegion.Rows.Count
'MsgBox d
Dim x As Range
Range("c:c").Clear
For i = 3 To d
Set x = Range(Cells(1, "B"), Cells(i - 1, "B")).Find(Cells(i, "B"))
If x Is Nothing Then
Else
If x.Offset(0, 1) = "" Then
x.Offset(0, 1) = 2
Else
x.Offset(0, 1) = x.Offset(0, 1) + 1
End If
End If
Next
y = Application.WorksheetFunction.Max(Range(Cells(1, "C"), Cells(d, "C")))
MsgBox y
End Sub

お礼

ありがとうございました。
たすかります。

回答No.2

ja7awu

「マクロでやりたい」とありますが、結果をどのようにしたいのか
分かりませんので、一応、Msgboxに表示させています。

Sub test()
Dim MaxCount As Long
With Application.WorksheetFunction
MaxCount = .CountIf(Range("B2:B100"), .Max(Range("B2:B100")))
End With
MsgBox "最大数は、 " & MaxCount & " 個あります。"
End Sub

'---------

また、「ユーザー定義関数を作りたい」という意味であれば、こんな感じ
で如何でしょうか。 標準モジュールに下記コードを貼り付けます。

関数の使い方は、=MaxCount(B2:B100) 　です。

Function MaxCount(R As Range)
　　With Application.WorksheetFunction
　　　　MaxCount = .CountIf(R, .Max(R))
　　End With
End Function

補足

質問の書き方が悪くすみません。
指定セル範囲内で完全同一の数値または文字列のセルが一番多い数値または文字列を求めたいのです。
仮にB1:B18の範囲に、aaaという文字列が入ったセルが4個、bbbが3個、cccが2個、残りは同じのはない場合、「最大はaaaが4個」とわかるようにVBAでやりたいのです。

ワークシート関数なら配列数式（Ctr+Shift+Enter）で
{=MAX(COUNTIF($B$2:$B$18,B2:B18))}で4と出ます。

上記マクロを試したら同じデータなのに"最大数は、1個あります。"になってしまいました。
ユーザー定義関数でもためしましたが　=MaxCount(B2:B18)でこたえは1なのです。

どうしてでしょうか？

回答No.1

lonpoco

記述の方法は何通りかあると思いますが、範囲が固定なら下記でいかがでしょう。
Dim C As Integer '行
Dim D As Integer 'セル内
Dim E As Integer '最大値
Dim F As Integer '個数

E = 0
F = 0

For C = 2 To 100
D = ThisWorkbook.Worksheets("Sheet1").Cells(2, C).Value
If D > E Then
E = D
F = 1
ElseIf D = E Then
F = F + 1
End If
Next
ThisWorkbook.Worksheets("Sheet1").Range("C1") = F

補足

実行時エラー13
「型が一致しません」となってしまいました。

D = ThisWorkbook.Worksheets("Sheet1").Cells(2, C).Value
でひっかかるようです。

なお、データは文字列なので最大値はありません。
完全同一なセルの最大個数を求めたいのです。