Excelマクロのmsgboxに最頻出者名を表示したい

C列の３行目から３６０行目くらいまでのセルに半角英数の名前が入っています。
この中で最も多く出てくる名前をmsgboxで表示したいんです。
ただ、或る人物（例えばU.chief)は１位でも除外します。
Satou_M
Yoshida
Kusakabe
U.chief
U.chief
Satou_M
U.chief
上の例ではmsgboxにSatou_Mと出るようにしたいんです。

Worksheet関数のmode関数を利用して
　MsgBox Application.WorksheetFunction.Mode([c3:c367])
でやってみたんですが、modeは対象が数値でないとエラーになるみたいです。
半角英数の文字列で上のような事が出来る方法は無いでしょうか？
予め決まった一人を除外して最多者を出す方法、のほうは全然分かりません。 (^_^;

No.1 ベストアンサー 回答者： BLUEPIXY 回答日時： 2005/08/02 00:44

以前の質問で、文字列の最頻出値を求める関数を作ったことがあります。

http://okweb.jp/kotaeru.php3?qid=1143416
の＃３
U.chiefを除外するのは、
最初のfor each で登録しカウントする部分をスキップする部分を追加すればいいです。
初めのfor eachの中身を
if x.value <> "U.chief" then
…
end if
のようにくるめばいいと思います。

No.4 回答者： imogasi 回答日時： 2005/08/02 22:15

データがＡ列にあるとする。

Sub test01()
d = Range("A65356").End(xlUp).Row
startrow = 2 'データ開始行
workc = "x" 'ワーク列
jyogai = "df" ' 除外者氏名１名
'--- copy sort
Range(Cells(startrow, "A"), Cells(d, "A")).Copy
Range(workc & startrow).PasteSpecial
Selection.Sort Key1:=Range(workc & startrow), Order1:=xlAscending
'-----
hmax = 1
smax = Cells(startrow, workc)
s = Cells(startrow, workc)
h = 1
'-----
For i = 3 To d
If Cells(i, workc) = jyogai Then Exit For
If Cells(i, workc) = s Then
h = h + 1
Else

If hmax < h Then
hmax = h
h = 1
smax = s
Else
h = 1
End If
End If
s = Cells(i, workc)
Next i
'----
MsgBox smax & "が最頻出" & hmax & "回"
End Sub
エクセルソートを使っているので、ワーク列を使います。
長いコードを短くならないか考えた結果です。Ｄｉｍなどは省いてますのでよろしく。
startrow = 2 'データ開始行
workc = "x" 'ワーク列Ｘ列
jyogai = "df" ' 除外者氏名１名
は質問者が適当に変えてください。
簡単テスト例。
a
a
a
c
c
c
d
df
df
e
e
f
q
r
s
s
s
w
z
c
df
df
df
でｃが４件
最初が除外者だとおかしくなるかもしれないと気づいたが、そのままにしました。

No.3 回答者： at121 回答日時： 2005/08/02 15:47

選択範囲　（　C３行目からC400行目くらいまで　）　の中で

除外対象　（例えばU.chief　　複数設定可)　　　を考慮して

最も多く出てくる名前を　抽出
同順の場合　　AA＋bb　と列挙　


↓　モジュール　↓

Sub 指定範囲を結合して最多頻出項目を抽出する()

除外対象 = "太郎,U.chief" '　半角　","　区切り　で　複数設定可

Set 選択範囲 = Range("C3:C400").SpecialCells(xlCellTypeConstants)
要素数 = 選択範囲.Count

文字列 = "" '文字列に結合
For Each 要素 In 選択範囲
文字列 = 文字列 + Trim(要素.Value) + "："
Next

For Each 語句 In Split(除外対象, ",")
文字列 = Replace(文字列, 語句 + "：", "") '対象外　語句を削除
Next

最多対象 = ""
最多数 = 0
Do While 1 < Len(文字列)

計数対象 = Split(文字列, "：")(0)
新文字列 = Replace(文字列, 計数対象 + "：", "") '対象文字列削除
'ダミー1文字に置き換えたものとの差＝対象数
対象数 = Len(Replace(文字列, 計数対象 + "：", "@")) - Len(新文字列)
文字列 = 新文字列

If 最多数 < 対象数 Then '最多　頻出
最多対象 = 計数対象
最多数 = 対象数
ElseIf 対象数0 = 対象数 Then '　同順位　頻出
最多対象 = 計数対象 & "＋" & 最多対象

End If

Loop

MsgBox "最多項目　=　" & 最多対象 & "／最多頻出数=" & 最多数

End Sub

この回答へのお礼

返事が遅れすみません。
変数が内容を表す漢字になっていて、とても分かり易かったです。
始め単なる解説文かと思ったんですが、立派なマクロなんですね。
文字列の最頻値を返す関数等は用意されてないようで、LOOPを作って出さなきゃいけないんですね。
難しいマクロをとても見易く書いて頂き有り難うございました。
もちろんエラー無く動きました。　m(_ _)m

お礼日時：2005/08/03 01:49

No.2 回答者： Wendy02 回答日時： 2005/08/02 01:05

こんばんは。

＞MsgBox Application.WorksheetFunction.Mode([c3:c367])
あえて、こうしようと思った理由は、何かありますか？

例えば、

補助列を設けて
D3:
=IF(C3="","",IF((MATCH(C3,$C$3:$C$367,0)=ROW(A1)),COUNTIF($C$3:$C$367,C3)+ROW(A1)/1000,""))

E3:
=IF(COUNT($D$3:$D$367)>=ROW(A1),INDEX($C$3:$C$3671,MOD(LARGE($D$3:$D$367,ROW(A1)),1)*1000,1),"")

こんな風にすれば、並び替えをしなくても、順位が取れますから、必要なものを抜き出せばよいと思います。

しかし、こういう式を、そのまま、VBAに持ち込んでも、メリットが少ないのです。そこで以下のようにはなりますが、これは、全て、並べ替えた順序を配列の中に用意してあります。ですから、上から、順に取り出すことも可能です。

Option Explicit
Option Compare Text
Sub 検出リスト()
　Dim myDic As Object, rng As Range
　Dim i As Long, j As Long, k As String, t As Variant, n As Long
　Dim a() As Variant
　'データ範囲
　Set rng = Range("C3", Range("C65536").End(xlUp))
　'除外データ
　Const Exception As String = "U.chief"
　'
　Set myDic = CreateObject("Scripting.Dictionary")
　For i = 1 To rng.Rows.Count
　k = rng.Cells(i, 1).Value
　'ディクショナリに確保
　If myDic.Exists(k) = False Then
　　myDic.Add k, Application.CountIf(rng, k)
　End If
　Next i
　ReDim a(0 To myDic.Count - 1, 0 To 1)
　For Each t In myDic.keys
　a(j, 0) = myDic.Item(t)
　a(j, 1) = t
　j = j + 1
　Next t
　BB_Sort a()
　For n = LBound(a(), 1) To UBound(a(), 1)
　'除外項目
　If Not a(n, 1) Like "*" & Exception & "*" Then
　　MsgBox a(n, 1)
　　Exit Sub
　End If
　Next n
　Set myDic = Nothing
　Set rng = Nothing
End Sub
Private Function BB_Sort(a() As Variant)
　'バブルソート
　Dim u As Long
　Dim i As Long
　Dim j As Long
　Dim t1 As Variant, t2 As Variant
　u = UBound(a(), 1)
　i = LBound(a(), 1)
　Do While i < u
　j = u
　Do While j > i
　　If a(j, 0) > a(i, 0) Then '降順
　　t1 = a(j, 0)
　　t2 = a(j, 1)
　　a(j, 0) = a(i, 0)
　　a(j, 1) = a(i, 1)
　　a(i, 0) = t1
　　a(i, 1) = t2
　　End If
　　j = j - 1
　Loop
　i = i + 1
　Loop
End Function