最も多い文字列を検索するには

皆様いつもお世話になっております。
最も多い文字列を検索するにはどのようにすればよいでしょうか。
具体的には
(1)A列に6文字の文字列が並んでいます。
(2)先頭4文字の文字列で最も多い種類の文字列の値を取得する
(3)最も多い文字列以外の文字列を含む行を削除する
というプログラムを組みたいと思います。

よろしくお願いします。

No.2 ベストアンサー 回答者： KenKen_SP 回答日時： 2006/11/17 10:40

ご自分でつくったコードをちゃんと提示しましょう。

それが多くの回答をもらう
ポイントです。

> (3)最も多い文字列以外の文字列を含む行を削除する

含む？ これだと全ての行が削除対象になる気がしますが...
始まる...ですかね？

プログラムを組むまでもなく、作業列を2つ設けて数式
　　B1 セル： =LEFT(A1,4)
　　C1 セル： =COUNTIF（B:B,B1)
とし、データ終端までフィルでコピー。あとは C 列にオートフィルターをかけ、
最頻値以外を抽出して削除すれば良い気がしますが...

作業列を使わず、Excel VBA だけで完結させるなら、こんな感じかと。

Sub Sample()
　　
　　Dim Dic　　　　 As Object
　　Dim rTable　　　As Range
　　Dim rDelRow　　 As Range
　　Dim C　　　　　 As Range
　　Dim vDat　　　　As Variant
　　Dim sKey　　　　As String
　　Dim sModeKey　　As String
　　
　　' 頭から切り出して調べる文字数
　　Const CHARCOUNT = 4
　　
　　' データ範囲
　　With Worksheets("Sheet1")
　　　　Set rTable = Range(.Cells(1, "A"), _
　　　　　　　　　　 .Cells(Rows.Count, "A").End(xlUp))
　　End With
　　' (2)先頭4文字の文字列で最も多い種類の文字列の値を取得する
　　' --> sModeKey です
　　Set Dic = CreateObject("Scripting.Dictionary")
　　sModeKey = ""
　　For Each vDat In rTable.Value
　　　　' 空または CHARCOUNT 以下のデータはここでは無視
　　　　If Not IsEmpty(vDat) And Len(vDat) >= CHARCOUNT Then
　　　　　　sKey = Left$(vDat, CHARCOUNT)
　　　　　　' ※ Dictionary は キーが重複するとエラーになります
　　　　　　If Dic.Exists(sKey) Then
　　　　　　　　Dic(sKey) = Val(Dic(sKey)) + 1
　　　　　　Else
　　　　　　　　Dic.Add Key:=sKey, Item:=1
　　　　　　End If
　　　　　　' 最頻値更新
　　　　　　If Len(sModeKey) > 0 Then
　　　　　　　　If Dic(sKey) > Dic(sModeKey) Then
　　　　　　　　　　sModeKey = sKey
　　　　　　　　End If
　　　　　　Else
　　　　　　　　sModeKey = sKey
　　　　　　End If
　　　　End If
　　Next
　　' (3)最も多い文字列"以外"で"始まる"行を Select する
　　' 本当は Find を使った方が速いけど長くなるので...
　　If Len(sModeKey) > 0 Then
　　　　sModeKey = sModeKey & "*"
　　　　For Each C In rTable.Cells
　　　　　　If Not C.Value Like sModeKey Then
　　　　　　　　If rDelRow Is Nothing Then
　　　　　　　　　　Set rDelRow = C
　　　　　　　　Else
　　　　　　　　　　Set rDelRow = Union(rDelRow, C)
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　Else
　　　　' 最頻値が得られなければデータ範囲全体
　　　　Set rDelRow = rTable
　　End If
　　' 削除確認してOKなら削除
　　If Not rDelRow Is Nothing Then
　　　　rDelRow.EntireRow.Select
　　　　If MsgBox("削除OK?", vbOKCancel + vbExclamation) = vbOK Then
　　　　　　Selection.Delete Shift:=xlShiftUp
　　　　　　Selection.Cells(1).Select
　　　　End If
　　Else
　　　　MsgBox "削除対象はありません.", vbInformation
　　End If
　　' 後始末
　　Set rTable = Nothing: Set rDelRow = Nothing
　　Set Dic = Nothing
End Sub

この回答へのお礼

KenKen_SPさん、こんにちは。
マクロの中で文字の最頻値以外の文字列の行を削除する必要があったので、質問させていただきました。
示していただいたコードですが、細かい場合分けまで考慮していただき参考になりました。
ありがとうございます。

お礼日時：2006/11/24 22:36

No.1 回答者： ctrlzr 回答日時： 2006/11/16 21:36

要は、先頭4文字でもっともダブりが少ない文字列を抜き出すということですね。

私はよくDictionaryやCollectionを使います。名前つき配列
というものです。同じ名前では登録できないので、先頭から4文字を加えて、全部同じなら１つ、全部異なるなら、４つになります。
A列の記載があるので、Excelの前提です。（試してません^_^;
dim rg as Excel.Range
dim dic as Scripting.Dictionary
dim adrs as String
dim i as long
dim lcnt as long
set rg = ActiveSheet.Range("A1")
do while rg.text <> ""
set dic = New Scripting.Dictionary
for i=1 to 4
dic.add mid$(rg.text,i,1) 'ダブってもエラーにならなかったはず...
next
if (lcnt < dic.Count) then
lcnt = dic.Count
adrs = rg.address
end if

set rg = rg.Offset(1,0)
loop

この回答への補足

ctpzrさんありがとうございます。
試してみましたが、2行目の "as ScriptingDictionary"のところで"ユーザ定義型は定義されてません"とエラーが出てしまいます。
どのように対処したらよいでしょうか?

補足日時：2006/11/24 20:23