エクセルVBAでプログラムを作りたいんですが、、、

質問

ある文字列の中から漢字のみを抜きだしセルに表示、その漢字の個数とそれぞれの漢字の個数をセルに表示するにはどのようなプログラムにしたらよいのでしょうか？
例えば、「私は昨日、日光東照宮へ私の家族といっしょに行った」⇒私２、昨１、日２、…漢字の総数１２というような感じです。拙い説明で分かりずらいかもしれませんが、わかる方どうかお力を貸してください。

回答No.3

tom04 · ベストアンサー

続けてお邪魔します。

＞もう少し簡単なプログラムがあれば・・・
というコトですが、この程度しか思いつきませんので、
前回のコードとその説明を加えたものをもう一度載せてみます。

Sub Sample1()
'変数の宣言
Dim k As Long, cnt As Long, str As String, c As Range

'C・D列の消去
Range("C:D").ClearContents

'A1セルの1文字目～最終文字まで
For k = 1 To Len(Range("A1"))

'一文字ずつを変数（str）に格納
str = Mid(Range("A1"), k, 1)

'もしstrが「漢字」であれば・・・（おそらくすべての漢字が網羅されていると思います）
If str Like "[一-黑]" Then

'C列に「str」が存在するかどうか確認
Set c = Range("C:C").Find(what:=str, LookIn:=xlValues, lookat:=xlWhole)

'もしC列に「str」がなければ
If c Is Nothing Then

'cnt（表示用の行番号として使用）を1つずつ増やす
cnt = cnt + 1 '←最初は「1」となる

'C列の「cnt」行の
With Cells(cnt, "C")

'値はstrを代入
.Value = str

'その右隣りのセルに「1」を代入
.Offset(, 1) = 1
End With

'そうでない場合は
Else

'C列にstrがある行の右隣りの値は、入力済みの数値に1をプラス
c.Offset(, 1) = c.Offset(, 1) + 1
End If
End If

'次のk（文字）へ！←（A1セルの最後の文字まで一文字ずつ順にループ）
Next k

'C列最終行の2行下のセルの
With Cells(Rows.Count, "C").End(xlUp).Offset(2)

'値は「総数」に
.Value = "総数"

'その右隣りのセルはD列数値の合計を！
.Offset(, 1) = WorksheetFunction.Sum(Range("D:D"))
End With
End Sub

※　一応上記のような考え方でのコードです。
この程度でよろしいでしょうかね？m(_ _)m

お礼

わかりやすい説明をありがとうございます！！
大変たすかりました。また何かありましたらお願いします！

回答No.2

tom04

No.1です！
たびたびごめんなさい。

前回のコードの
＞If str Like "[亜-黑]" Then
の行を
＞If str Like "[一-黑]" Then
に変更してください。
前回のコードでは漏れがあるみたいです。

※　今回も詳しく検証していませんので漏れがあったらごめんなさいね。m(_ _)m

お礼

ありがとうございます！！
実行してみたらちゃんとできました。
ただVBA超初心者なんで何が何を意味してるかが分からないのでもう少し簡単なプログラムがあれば、もしくは簡単で構わないので説明していただけるとありがたいです汗。

回答No.1

tom04

こんばんは！
色々やり方はあると思いますが、一例です。

「ある文字列」はA1セルにあるとし、C列に漢字を、D列に個数を表示するとします。
Sheetモジュールです。

Sub Sample1()
Dim k As Long, cnt As Long, str As String, c As Range
Range("C:D").ClearContents
For k = 1 To Len(Range("A1"))
str = Mid(Range("A1"), k, 1)
If str Like "[亜-黑]" Then
Set c = Range("C:C").Find(what:=str, LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
cnt = cnt + 1
With Cells(cnt, "C")
.Value = str
.Offset(, 1) = 1
End With
Else
c.Offset(, 1) = c.Offset(, 1) + 1
End If
End If
Next k
With Cells(Rows.Count, "C").End(xlUp).Offset(2)
.Value = "総数"
.Offset(, 1) = WorksheetFunction.Sum(Range("D:D"))
End With
End Sub

こんな感じではどうでしょうか？m(_ _)m