表の中でもっとも多く使用されている文字（数字）を抽出するには

質問

|Ａ|Ｂ|Ｃ|Ｄ|
--------------
１|あ|い|う|え|
--------------
２|お|あ|あ|か|
--------------

上記は１行目に左から「あ」「い」「う」「え」が入力されていることを表しています。

この表の中から、一番多く入力されている文字だけを別のセルに抽出させるにはどのようにしたら良いでしょうか。
上記の例を使用すると、A列の５行目（任意のセル）に「あ」と抽出するようにしたいです。

いろいろと調べてみましたが、このように表の中で最も多く入力されている、「文字」または「数字」だけを抽出するという処理方法がみつかりませんでした。
マクロなら可能でしょうか？

このような処理ができる関数もなさそうなので、無理なのかな。

アドバイスを御願い致します。

回答No.13

sakenomo

No.8です。

前記のコード18行目(空白行を含む)の

> Cosu(i) = Cosu(i) + 1 　　　　は、

　Cosu(i) = 1 　　　　　　　　　　　に訂正します。

結果は変わらないのですが、気になったもので…。

…というか、For Each～Next間は、imogasiさん方式がいいですね。

回答No.12

imogasi

＃１０の補足です。
＞E1：F1に結果を出力してしまうと、最初にデータを入力していた部分と重なってしまわないでしょうか？
Ｅ１より右列にも、元データがあるのなら、例えば未使用のＱ列、Ｒ列を使って下さい。それぐらいは修正変更して頂けるとの前提で書いてます。
下記に修正したものを書きます。どこを変えれば良いか
両者比較すればわかります。
＞マクロの処理を連続して行ってみると、・・・加算される
そうですね。クリア処理が要りますね。
下記の最初の１行を追加します。
Sub test02()
Range("s1:t100").ClearContents
j = 1
Cells(1, "S") = Cells(1, "A")
Dim c As Range
For Each c In Range("a1:d5")
For i = 1 To j
If Cells(i, "S") = c Then
Cells(i, "T") = Cells(i, "T") + 1
GoTo p01
End If
Next i
j = j + 1
Cells(j, "S") = c
Cells(j, "T") = 1
p01:
Next
Range(Cells(1, "S"), Cells(j, "T")).Select
Selection.Sort Key1:=Range("T1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False
Cells(1, "Q") = Cells(1, "S")
Cells(1, "R") = Cells(1, "T")
End Sub
＞このようなマクロの処理を数式のように常にアクティブな状態にさせることは可能でしょうか？
この処理は値を出して終わりと言う型ではないので、自家製関数には出来ません。
シートにボタンを１つ貼りつけ、必要な時、ボタンをクリックするとこの処理を実行すると言うのなら
Private Sub CommandButton1_Click()

End Sub
この真中に上記を挟むことによって可能です。
＞データに変更がある度に、結果も変更されるようにできたらいいなと
これは無駄な処理を毎回データ入力時にさせることになり、データ数が多いと、入力レスポンスタイムに影響しイライラするのではないかと思いますので賛成しません。
こう言う要望の処理を、イベントを捉えるといいますが、シートのイベントとして「値が変った」、「セル選択が変った」などがありますが、私はこの内容に不満足でこれを使う気になりません。

回答No.11

damejan

プログラムでやるのも面倒くさいですね。Unix系の標準のコマンドだけで実現できますので、参考に書いておきます。プログラムなんか組む必要はありません。
No.9と同様、テキストファイル（CSV形式）に出力されているとします（例えばファイル名は、test.tblとします）。

［test.tbl内容］
あ,な,の,ん,と,に
か,た,さ,ぱ,な,す
す,ろ,ふ,べ,ほ,じ
あ,な,め,よ,り,に
り,な,ず,に,ち,ぱ
あ,な,け,ふ,と,み
こ,あ,て,べ,を,ね

#一番多かった文字を出力する例
cat test.tbl | tr ',' '\n' | sort | uniq -c | sort -rn | head -1 | cut -f2
#結果
な

#一番多かった文字を頻度とともに出力する例
cat test.tbl | tr ',' '\n' | sort | uniq -c | sort -rn | head -1
#結果
5 な

#上位5個をの文字を頻度とともに出力する例
cat test.tbl | tr ',' '\n' | sort | uniq -c | sort -rn | head -5
5 な
4 あ
3 に
2 り
2 べ

お礼

御回答ありがとうございます。

ん～、私の理解を超えてしまっています（＾＾；
ですが、処理結果の出力は私がやりたいことなんです。
これを、なんとかエクセルで実現できればと思います。

わざわざ回答して頂き、ありがとうございました。
また何かアドバイスがありましたら、よろしく御願いします。

回答No.10

imogasi

ホンと長いプログラムが多いですね。＃９さんに触発されて
Sub test02()
j = 1
Cells(1, "H") = Cells(1, "A")
Dim c As Range
For Each c In Range("a1:d5")
For i = 1 To j
If Cells(i, "H") = c Then
Cells(i, "I") = Cells(i, "I") + 1
GoTo p01
End If
Next i
j = j + 1
Cells(j, "H") = c
Cells(j, "I") = 1
p01:
Next
Range(Cells(1, "H"), Cells(j, "I")).Select
Selection.Sort Key1:=Range("I1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False
Cells(1, "E") = Cells(1, "H")
Cells(1, "F") = Cells(1, "I")
End Sub
（テストデータ）Ａ１：Ｅ５に
a b c r
s a s t
a c a y
w a f s
s d g a
（結果）Ｈ１：Ｉ１１に
a 6
s 4
c 2
b 1
r 1
t 1
y 1
w 1
f 1
d 1
g 1
（結果）Ｅ１：Ｆ１に
a 6
行数列数が増えたときどこを変えれば良いか判るでしょう。

お礼

御回答ありがとうございます。

これは私の要望にさらに機能を付けて頂いた処理になっていますね（＾＾）
実は多い順に表示できたらいいなー、とも思っていました。

実際に試してみたのですが、ちょっと上手くいきませんでした。

「（結果）Ｅ１：Ｆ１に
a 6 」

ですが、E1：F1に結果を出力してしまうと、最初にデータを入力していた部分と重なってしまわないでしょうか？
実際表示されませんでした。

あと、このようなマクロの処理を数式のように常にアクティブな状態にさせることは可能でしょうか？
データに変更がある度に、結果も変更されるようにできたらいいなと思います。
またこのマクロの処理を連続して行ってみると、もっとも多くある文字だけが加算されていってしまいます。

例の１部を使用して例えてみると、
＜一回目＞
a 6
s 4
c 2
＜二回目＞
a 12
s 4
c 2
＜三回目＞
a 18
s 4
c 2

と言ったように、処理した回数のみ加算されていきます。

何とか関数のみで多い順に表示したり、カウントしたりしようと考えてみましたが、かなり面倒な処理になってしまいそうです。

他に何かアドバイスがありましたら、よろしく御願いします。

回答No.9

damejan

どうしてもエクセル上（VBA）でやらなければ、いけないのでしょうか？ 他の方の例を見ていると、VBAでは大変そうですね。私だったら、テキストファイル（CSV形式）で出力して、Perlなどを使って処理します。例えば、こんな感じです。

$file=@ARGV[0];
open(IN, "$file");

%NUM;
while(<IN>){
　　chop();
　　@record = split(/,/);
　　foreach $word (@record){
　　　　$NUM{$word}++;
　　}
}
close(IN);

$max_item = "";
$max_num = 0;
foreach $item (sort (keys(%NUM))){
　　printf("%s: %d\n", $item, $NUM{$item});
　　if($NUM{$item} > $max_num){
　　　　$max_num = $NUM{$item};
　　　　$max_item= $item;
　　}
}
printf("---------- MAX ----------\n");
printf("%s: %d\n", $max_item, $max_num);

補足

御回答ありがとうございます。

私以外の人も使用するので、やはりエクセルで処理することが必要になってきます。
Perlバージョンも参考にさせて頂きますね。

わざわざ、ありがとうございました。

回答No.8

sakenomo

時間ができたので、作ってみました。

VBAの標準モジュールに貼り付け、"挿入"→"関数"で、ユーザー定義関数として試してみてください。

Function InLarge(データ As Range) As String
　　Dim moji() As String, Cosu() As Integer, i As Integer
　　Dim myRange As Range, Most As String, ip As Integer

　　Application.Volatile
　　ReDim moji(データ.Count)
　　ReDim Cosu(データ.Count)

　　For Each myRange In データ
　　　　If myRange.Text <> "" Then
　　　　　　Do
　　　　　　　　　　If moji(i) = myRange.Text Then
　　　　　　　　　　　　Cosu(i) = Cosu(i) + 1
　　　　　　　　　　　　Exit Do
　　　　　　　　　　Else
　　　　　　　　　　　　If moji(i) = "" Then
　　　　　　　　　　　　　　moji(i) = myRange.Text
　　　　　　　　　　　　　　Cosu(i) = Cosu(i) + 1
　　　　　　　　　　　　　　Exit Do
　　　　　　　　　　　　End If
　　　　　　　　　　　　i = i + 1
　　　　　　　　　　End If
　　　　　　Loop
　　　　　　i = 0
　　　　End If
　　Next myRange
　　i = 1
　　Do
　　　　If Cosu(ip) <= Cosu(i) Then
　　　　　　If Cosu(ip) = Cosu(i) Then
　　　　　　　　Most = Most & "," & moji(i)
　　　　　　Else
　　　　　　　　ip = i
　　　　　　　　Most = ""
　　　　　　End If
　　　　End If
　　　　i = i + 1
　　Loop Until Cosu(i) = 0
　　InLarge = moji(ip) & Most & "(" & Cosu(ip) & ")"
End Function

補足

御回答ありがとうございます。

これは凄いですね（＾＾）
実際に使用してみたのですが、ユーザー関数として自由に使用できるので、いろいろな場面で使用することができそうです。
私以外の方でも、このような処理をしたいと思った方は是非使用してみた方が良いと思います。

このコードがどのように組まれているのか分かりませんが、知識があればこういうことも出来てしまうのですね。

今後も、いろいろと勉強したいと思います。

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

回答No.7

mousengoke

Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
　　Dim sheetname As String
　　sheetname = "Sheet1" 'この部分に対象となるワークシート名を入れてください。
　　If ActiveSheet.Name = sheetname Then
　　　　Call maxmoji
　　End If
End Sub

Private Sub maxmoji()
　　　　Dim gyou As Integer
　　　　Dim retsu As Integer
　　　　Dim countmoji(100, 4)
　　　　Dim mojishu As Integer
　　　　Dim cellchar As String
　　　　Dim seirinum As Integer

　　　　Dim i As Integer
　　　　Dim j As Integer

　　　　Const moji = 0
　　　　Const kazu = 1
　　　　Const leftbig = 2
　　　　Const rightbig = 3

　　　　Dim maxchar As String
　　　　Dim maxnum As Integer
　　　　Dim thiscount As Integer

　　　　gyou = Range("A1").End(xlDown).Row
　　　　retsu = Range("A1").End(xlToRight).Column

　　　　mojishu = 0

　　　　For i = 1 To gyou
　　　　　　　　For j = 1 To retsu
　　　　　　　　　　　　cellchar = Cells(i, j).Value
　　　　　　　　　　　　seirinum = 0
　　　　　　　　　　　　If mojishu = 0 Then
　　　　　　　　　　　　　　　　countmoji(0, moji) = cellchar
　　　　　　　　　　　　　　　　countmoji(0, kazu) = 1
　　　　　　　　　　　　　　　　mojishu = 1
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　Do
　　　　　　　　　　　　　　　　　　　　If countmoji(seirinum, moji) = cellchar Then
　　　　　　　　　　　　　　　　　　　　　　　　countmoji(seirinum, kazu) = countmoji(seirinum, kazu) + 1
　　　　　　　　　　　　　　　　　　　　　　　　Exit Do
　　　　　　　　　　　　　　　　　　　　ElseIf countmoji(seirinum, moji) > cellchar Then
　　　　　　　　　　　　　　　　　　　　　　　　If countmoji(seirinum, leftbig) > 0 Then
　　　　　　　　　　　　　　　　　　　　　　　　　　　　seirinum = countmoji(seirinum, leftbig)
　　　　　　　　　　　　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　　　　　　　　　　　　　countmoji(seirinum, leftbig) = mojishu
　　　　　　　　　　　　　　　　　　　　　　　　　　　　countmoji(mojishu, moji) = cellchar
　　　　　　　　　　　　　　　　　　　　　　　　　　　　countmoji(mojishu, kazu) = 1
　　　　　　　　　　　　　　　　　　　　　　　　　　　　mojishu = mojishu + 1
　　　　　　　　　　　　　　　　　　　　　　　　　　　　Exit Do
　　　　　　　　　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　　　　　　　　　If countmoji(seirinum, rightbig) > 0 Then
　　　　　　　　　　　　　　　　　　　　　　　　　　　　seirinum = countmoji(seirinum, rightbig)
　　　　　　　　　　　　　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　　　　　　　　　　　　　countmoji(seirinum, rightbig) = mojishu
　　　　　　　　　　　　　　　　　　　　　　　　　　　　countmoji(mojishu, moji) = cellchar
　　　　　　　　　　　　　　　　　　　　　　　　　　　　countmoji(mojishu, kazu) = 1
　　　　　　　　　　　　　　　　　　　　　　　　　　　　mojishu = mojishu + 1
　　　　　　　　　　　　　　　　　　　　　　　　　　　　Exit Do
　　　　　　　　　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　　　Loop
　　　　　　　　　　　　End If
　　　　　　　　Next
　　　　Next

　　　　maxnum = 0
　　　　For i = 0 To mojishu
　　　　　　　　thiscount = countmoji(i, kazu)
　　　　　　　　If thiscount > maxnum Then
　　　　　　　　　　　　maxnum = thiscount
　　　　　　　　　　　　maxchar = countmoji(i, moji)
　　　　　　　　ElseIf thiscount = maxnum Then
　　　　　　　　　　　　maxchar = maxchar & " , " & countmoji(i, moji)
　　　　　　　　End If
　　　　Next

　　　　Cells(gyou + 3, 1).Value = maxchar & "(" & maxnum & "個)"

End Sub

本当はnishi6さんみたいに関数を作ったほうがいいのですが僕にはああいう風にセルの範囲をしていたものを処理する技術がないので前に僕が作った関数を元に進めて生きたいとオみます。
ただし結果の表示場所はデータの範囲の最下列より二つ空けてその下に表示させるようにしました。あと、表示形式はnishi6さんと同じものにしました。

あと、マクロは標準モジュールを開いてそこに記入するのが普通なのですが今回のマクロはThisWorkbookの方にコピーしてください。

お礼

御回答ありがとうございます。

かなり長いコードですね。
わざわざ作成して頂き、ありがとうございます。

だんだんとマクロについて理解できるようになってきました（＾＾）
このコードの意味は今は分からないですが、今後の勉強材料としても使わせて頂きますね。

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

回答No.6

sakenomo

数字なら、ＭＯＤＥというワークシート関数があります。
ヘルプをご覧になり、いろいろ試してみてください。

お礼

御回答ありがとうございます。
MODE関数をと調べてみます。

いろいろな関数がわかり、勉強になります（＾＾）

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

回答No.5

nishi6

ユーザー定義関数を作ってみました。A5に式を入力してみて下さい。

=maxNum_Chr("A1:B4","D2:D5","F1:K6") のように、調べる領域を必要なだけ指定します。

例えば、「あ」が9個で一番多ければ、あ(9個)　と表示。
「あ」と「い」と「1」が3個で一番多ければ、あ,い,1(3個)　と表示します。

Function maxNum_Chr(rg1, ParamArray rg2())
　　Dim cot As Long, cot2 As Long　'2つ目以降のセル領域の個数
　　Dim rgArea As Range　　　　　　'結合したセル領域
　　Dim dt() As String　　　　　　 'セルの値を取り込む配列
　　Dim rg As Range　　　　　　　　'セル

　　Application.Volatile
　　'飛び離れた領域を同一視するようにします
　　Set rgArea = Range(rg1)
　　　　If UBound(rg2) <> -1 Then
　　　　　　For cot = LBound(rg2) To UBound(rg2)
　　　　　　　　Set rgArea = Application.Union(rgArea, Range(rg2(cot)))
　　　　　　Next
　　　　End If
　　　　'セルの値を取り込みます
　　　　Dim num As Long　　　　　　'データ個数
　　　　num = rgArea.Count
　　　　ReDim dt(num)
　　　　　　cot = 0
　　　　　　For Each rg In rgArea
　　　　　　　　cot = cot + 1: dt(cot) = rg.Text
　　　　　　Next

　　'セルの値を比較します
　　Dim chkDT As String
　　Dim nMAX As Integer, cCot As Integer
　　　　For cot = 1 To num
　　　　　　If dt(cot) <> "" Then
　　　　　　　　chkDT = dt(cot): cCot = 1
　　　　　　　　For cot2 = cot + 1 To num　　'個数をカウント
　　　　　　　　　　If chkDT = dt(cot2) Then
　　　　　　　　　　　　dt(cot2) = "": cCot = cCot + 1
　　　　　　　　　　End If
　　　　　　　　Next

　　　　　　　　If nMAX = cCot Then　　　　　'最大個数が複数
　　　　　　　　　　maxNum_Chr = maxNum_Chr & "," & chkDT
　　　　　　　　ElseIf nMAX < cCot Then　　　'最大は１つのみ
　　　　　　　　　　maxNum_Chr = chkDT: nMAX = cCot
　　　　　　　　End If
　　　　　　End If
　　　　Next

　　maxNum_Chr = maxNum_Chr & "(" & nMAX & "個)"
End Function

お礼

nishi6さん、御回答ありがとうございます。

早速試してみたのですが、上手くいきません。
恐らくVB自体初めて扱うので、私の方に不備があると思いますが（ー＿ー；

「プロジェクト エクスプローラ」を開き、表が入っているシートを選択しました。
すると、ウィンドウが開いたので、そこに教えて頂いたコードを記述して、閉じました。
上右のプルダウンで(General)となっていましたが、これはworksheetにしなくても良いんですよね？

そして、表に戻って適当なセルに教えて頂いた式を範囲を変えてから記述。
リターンしてみましたが、「#VALUE!」と表示されて上手くいっていないようです。

ブック自体を１度保存してから、再度開いた時にマクロを有効にするかどうか聞かれたので、有効にするを選択して、また実行してみましたがやはりできませんでした。

おそらく簡単なことができていないだけの事だと思いますが、アドバイスを頂けると助かります。

またこの処理を表の中のデータを変更しても、その都度自動に処理してくれるようにすることはできるでしょうか？

お手数をおかけ致しますが、よろしく御願いします。

補足

いろいろと試してみましたが、「#NAME？」と表示されたり、「名前が適切ではありません」など表示されることもあります。

ん～、私にはもうお手上げな状態です。

アドバイスをよろしく御願いします。

回答No.4

mousengoke

3で説明を入れるのを忘れていたのでこっちに書きます。

最上列の左から連続して右側に連続してデータのあるところまでと最左列の一番上から連続してデータがあるところまでで囲まれた中で一番多い文字を導き出します。
同数があれば" , "でくぎって表示します。

でも表示する部分は固定なんですよね。
仕様ミスかな?

他にもバグがあるかもしれません。

お礼

こんばんは。
mousengokeさん、御回答ありがとうございます。

先程教えて頂いたコードを試してみたところ、上手くできました（＾＾）
実は今回が始めてVBAを触ってみるので、いろいろとサイトを調べて勉強してみました。

教えて頂いたコードを、「プロジェクト エクスプローラ」を開き、その中で実行したいシートの名前を開いて、そのまま記述するだけでいいんですよね？
あとは、マクロの実行を選ぶだけで処理はちゃんとできました。

もう１つできたらいいな、と思う事があるのですが、今回教えて頂いたマクロを常に実行できるようにはできるでしょうか？
例えば、表の入力されている内容を変更しても、自動的に処理されて抽出できるようにしたいのですが。

毎回マクロを実行するよりは、自動的に処理できると便利になりますので。

お手数をお掛けしますが、あともう少しアドバイスを頂けると嬉しく思います。

よろしく御願い致します。