簡易リストボックス

質問

以前
http://okwave.jp/qa/q8166399.html
で質問したものですが、Ｎo２の回答を参考にさせていただいております。
Ｎｏ２で教えていただいたコードをひらがなで入力してもカタカナとひらがなの両方が
ヒットするようにすることは可能なのでしょうか？

回答No.9

MarcoRossiItaly

＞sheet1、sheet2は特に名前は変えておりません。
　……
　他に、お気づきの点ありがすでしょうか？

今のところ、申し訳ありませんが、分かりません。原因不明です。

No.5 補足の「実行時エラー50290」というのは、Excel が 2 つの処理を同時にはできませんって感じのエラーのようなのですが、例えば Application.OnTime メソッドとか、別のマクロを背後で実行しているといったことはないでしょうか。WindowsUpdate の ServicePack の導入に失敗したことが関係していた、という話もどこかで見ました。

繰り返しになりますが、こちらの手元では問題なく動作しました。また、古いバージョンの VBA にはないコードを使っているというわけでも特にありません。

VBE のメニューでリセットし、ブックを保存し、Excel アプリケーションを終了し、再起動しても、同じ現象が発生してしまうでしょうか？バージョンはいくつでしょうか？

回答No.8

MarcoRossiItaly

No.4～7 です。No.5 に補足が付いていたのですね。すみません、今、気付きました。

＞……のようにエラーがでてしまい、……

No.6 の Sheet1 のコードのうち 3 行目と 6 行目に「sheet2」というオブジェクトが出てきますが、元データのリストのあるシート名が実際は異なっているようなら、2 つの「sheet2」を実際の名前で上書きしてください。

それでもエラーがなくならないようなら、そちらのシートの構造などを見るなどしないと、何とも言えないというところです。必要に応じて、追加の情報をください。とりあえずこちらの手元では問題なく動作することを確認済みなので、今のところ言えるのはそれくらいです。

度重なる訂正で、分かりづらくしてしまって申し訳ありませんでしたが、標準モジュールは No.5 のコード、Sheet1 は No.6 のコードを使うようにしてください。入力規則リストの元の値は、バージョンに応じて OFFSET 関数または名前の機能を使います。

補足

おはようございます。
sheet1、sheet2は特に名前は変えておりません。
sheet2のＡ列にデーターが４００行ほど入っています。
sheet1のＡ列の１行目から１４行目まで、=OFFSET(Sheet2!C$2,,,COUNTA(Sheet2!C:C)-1,1)
の設定にしております。
他に、お気づきの点ありがすでしょうか？

回答No.7

MarcoRossiItaly

No.5・6 です。何度もごめんなさい、錯覚によりミスりました…。次のとおりでお願いします。

●標準モジュール
　修正なし。No.5 のままが正しいコード。No.6 では、参照元の表の見出しまで消してしまうケースがあり、マクロのエラーとまではならないものの、ウマくない。

回答No.6

MarcoRossiItaly

No.5 です。No.5 のコードとほとんど同じですが、一部きれいでない箇所があったので、次のとおり修正させていただきます。前回と同様、ベストアンサーは辞退します。

●入力規則リストの元の値
　修正なし。ただし Excel2007 以前の場合は、質問文にある前回のご質問への回答 No.2 を参照。

●標準モジュール
　途中の 3 行を、次のとおり 2 行に書換え。

i = wS2.Cells(Rows.Count, "C").End(xlUp).Row
Application.ScreenUpdating = False
If i > 1 Then wS2.Range("c2:c" & i).ClearContents

↓

Application.ScreenUpdating = False
wS2.Range("c2:c" & i).ClearContents

●Sheet1
　2 回、登場する「Target.Select」のうち、2 回目を削除。意味のない処理のため。

以上により、修正版のコードはこうなります。頭文字を入力する操作の方法は、No.5 を参照。

●標準モジュール

Sub リスト()　　'この行から
Dim i As Long, cnt As Long, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")　　'←Sheet1は実際のSheet名に！
Set wS2 = Worksheets("Sheet2")　　'←Sheet2も実際のSheet名に！
Application.ScreenUpdating = False
wS2.Range("c2:c" & i).ClearContents
cnt = 1
For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
　　If wS2.Cells(i, "A").Value Like StrConv(Selection.Value, vbHiragana) & "*" Or _
　　wS2.Cells(i, "A").Value Like StrConv(Selection.Value, vbKatakana) & "*" Then　　' 2 行だけでもオッケー
　　　　cnt = cnt + 1
　　　　wS2.Cells(cnt, "C").Value = wS2.Cells(i, "A").Value
　　End If
Next i
Application.ScreenUpdating = True
End Sub　　'この行まで

●Sheet1

Private Sub Worksheet_Change(ByVal Target As Range)　　'この行から
If Target.Column = 1 And Target.Count = 1 Then
　　If Target.Value = "" Or WorksheetFunction.CountIf(Worksheets("sheet2").Range("c:c"), Target) Then Exit Sub
　　Target.Select
　　Call リスト
　　If Worksheets("sheet2").Range("c2").Value = "" Then Exit Sub
　　SendKeys "%{down}"
End If
End Sub　　'この行まで

回答No.5

MarcoRossiItaly

質問文の内容への直接の回答は No.1 で出ていますので、ベストアンサーは辞退します。

＞私はＶＢＡの方は全く解りませんので、どこを変えていけばいいかを具体に教えていただけますでしょうか？
　私の方で検証させていただきます。

「全く」お分かりにならない方が検証することは、不可能です。
論理的に矛盾しています。
また、基本的な動作確認くらいの話であれば、確認済みのものを投稿することは回答者として当然のことです。
（どうしても未確認のまま投稿するなら、その旨の断りが回答文にないとおかしいです）
質問者さんとしては一応、動くか確認されるでしょうが、たいていは結果的に無用なことです。
回答文のレベルもいろいろあるとは思いますが、ニーズに関する情報が質問文にきめ細かく載ってさえいれば、それに沿った回答が一発で出てくることが多いと思います。

それから、本当に何も分からないままコードを実行することは、お勧めしません。
そういう方は、ご自分では何もメンテナンスできませんし、何より悪意のあるコードだったら危険です。
こういうサイトでは多くの人の目があるとはいえ。
教わったコード中の単語が何を意味しているのかくらいは、ザッとでも見ておいてからお使いください。
VBE のヘルプなりインターネットでの検索により、情報はすぐに出てきます。
また、本来、QA サイトは人に業務委託するためにあるのではなく、質問と回答の場だと考えております。
「VBA では、ここはどう書くのですか？」といった内容のご質問だったら、十分に理解できるし、回答者としても喜んで回答します。

No.1 さんが書かれたコードをこちらで改造するのも気が引けるのですが、時間の関係もありますので、案として載せさせていただきます。シート上における Selection の位置はカーソル移動を見越して考える必要があり、割とややこしかったです。

入力の操作の方法
●マウス不使用
●頭文字を入力したら Enter で確定
●頭文字をタイプ中にオートコンプリートで続きの文字の候補が表示されたら Delete で消去
●プルダウンが表示されたら十字キーで選択し Enter で確定
●次の行に進むときは Enter または十字キーで移動

入力規則リストの元の値

=OFFSET(Sheet2!C$2,,,COUNTA(Sheet2!C:C)-1,1)

標準モジュール

Sub リスト()　　'この行から
Dim i As Long, cnt As Long, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1") '←Sheet1は実際のSheet名に！
Set wS2 = Worksheets("Sheet2") '←Sheet2も実際のSheet名に！
i = wS2.Cells(Rows.Count, "C").End(xlUp).Row
Application.ScreenUpdating = False
If i > 1 Then wS2.Range("c2:c" & i).ClearContents
cnt = 1
For i = 2 To wS2.Cells(Rows.Count, "A").End(xlUp).Row
　　If wS2.Cells(i, "A").Value Like StrConv(Selection.Value, vbHiragana) & "*" Or _
　　wS2.Cells(i, "A").Value Like StrConv(Selection.Value, vbKatakana) & "*" Then　　' 2 行だけでもオッケー
　　　　cnt = cnt + 1
　　　　wS2.Cells(cnt, "C").Value = wS2.Cells(i, "A").Value
　　End If
Next i
Application.ScreenUpdating = True
End Sub　　'この行まで

Sheet1

Private Sub Worksheet_Change(ByVal Target As Range)　　'この行から
If Target.Column = 1 And Target.Count = 1 Then
　　If Target.Value = "" Or WorksheetFunction.CountIf(Worksheets("sheet2").Range("c:c"), Target) Then Exit Sub
　　Target.Select
　　Call リスト
　　If Worksheets("sheet2").Range("c2").Value = "" Then Exit Sub
　　Target.Select
　　SendKeys "%{down}"
End If
End Sub　　'この行まで

補足

おはようございます。
時間が取れたのでやってみました。
http://uploda.cc/img/img51ec5cda97bbc.jpg
http://uploda.cc/img/img51ec5ce97f9c5.bmp
のようにエラーがでてしまい、さきに進むことができませんでした。
原因はわかりますでしょうか？
お手数おかけいたします。

回答No.4

MarcoRossiItaly

No.1 さんご回答への補足の件。横からすみませんが、気付いたことを。

こちらではきちんと検証していないのですが、例えば、

● SelectionChange ではなく Change とする。
● target.select を入れる。
●頭文字を入力した際は sendkeys "%{down}" により Alt+↓を入力させる。
●リストの値を選んで入力した際は sendkeys をしない。

というふうにして、力ずくでリストをドロップダウンさせようとすると、何か問題が起きそうでしょうか？もしそれが可能なら、カーソル移動を伴わずリストの自動表示ができそうな感じもするのですが…。

補足

おはようございます。
私はＶＢＡの方は全く解りませんので、どこを変えていけばいいかを
具体に教えていただけますでしょうか？
私の方で検証させていただきます。
ｍ＿＿ｍ

回答No.3

tom04

No.1です

補足の件について・・・

前回の回答でも書いたように、「オートコンプリート機能」のような操作ではなく
Changeイベントでの方法になります。

すなわち一旦Enterで確定しないとマクロが走りませんので、
リストにはすべてのデータが表示されてしまいます。

Changeイベントで「Enter」を押したら元のセルに戻るように試してみましたが
これでは全く先へ進めなくなりますので、あきらめました。

じっくり考えれば何か方法があるような気がするのですが、
ん～～～今はいい案が浮かびません。

どうもごめんなさいね。m（_ _）m

お礼

おはようございます。
なんか無理なことをお願いしてしまい申し訳ございません。
これだけでも十分すぎるくらいに作業が楽になりました。
ありがとうございました～＾＾

回答No.2

MarcoRossiItaly

前回も No.5 で回答した者です。無視は厳しいので、今回からは一人ひとりに、何かしらのお返事をお待ちしております。

前回の回答は、振り仮名の整備が前提になります。振り仮名がキチンとしていたほうがデータベースとしての価値が上がりますから、時間が取れるようなら頑張ってください。Excel では、振り仮名を使った計算をすることもあります。短時間での編集が可能かどうかはデータ全体の状況によりますが、結構たいへんなことも少なくないかもしれません。振り仮名を編集するショートカットキーは、Alt+Shift+↑です。全く同じ文字列が複数ある場合は、そのうち 1 つの振り仮名を正しく修正し、そのセルを他のセルにそのままコピペあるいは値複写してください。セルの値だけでなく、振り仮名も正しく上書きされます。オートフィルタも作業に役立つでしょう。

逆に振り仮名の内容がグチャグチャだと、それをリストで参照することにより別のセルに新たに入力した文字列においても、グチャグチャな振り仮名が維持されていますよ。

前回 No.5 のシートを作成したら、そのシート見出しを右クリックし、「コードの表示」。表示される画面に下のコードを貼り付けます。Excel ファイルはマクロブックとして保存。

これで J3 セルに入力された片仮名は、平仮名に自動的に変換されます。逆に平仮名を片仮名にしたいという場合は、コード中の「vbHiragana」を「vbKatakana」に書き換えてください。

平仮名と片仮名のどちらにすべきかは、前回も言ったとおり、そのファイルにおける振り仮名の設定に合わせるということです。

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("j3")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Target.Value = StrConv(Target.Value, vbHiragana)
Application.EnableEvents = True
End Sub

お礼

MarcoRossiItaly様、申し訳ございません。
Ｎｏ２でお答えいただいたものが、私の期待通りのものでしたのでこれで決めさせていただきました。
時間がなかなかとれませんが、時間がとれましたら検証させていただきますね～。
ありがとうございます。

回答No.1

tom04

こんにちは！
前回、回答したものです。

配置は前回同様として、Sheet2のA列のデータがひらがな、カタカナ、その他いろいろ混在しているという解釈で・・・

前回のコードの
＞If wS2.Cells(i, "A") Like Selection & "*" Then
の部分を
If wS2.Cells(i, "A") Like Selection & "*" Or _
wS2.Cells(i, "A") Like StrConv(Selection, vbHiragana) & "*" Or _
wS2.Cells(i, "A") Like StrConv(Selection, vbKatakana) & "*" Then

の3行に変更してみてください。

※　ひらがな・カタカナは全角だという前提です。
※　実際のデータがこちらでは判らないのですが、
もっと突き詰めればアルファベットの大文字・小文字の場合や全角・半角等々の問題が出る可能性がありますね。

とりあえずはこの程度で・・・m（_ _）m

補足

おはようございます。返事が遅れて申し訳ございません。
時間がなくて、遅くなってしまいましたが、やっとできました。
ありがとうございます。
ところで、頭文字入力後に一度別のセルをクリックしてからでないと頭文字が認識できないのは
治すことができるのでしょうか？
たびたび申し訳ございません。