VBA フォームのテキストボックス 1文字検索

質問

お世話になります。

フォーム上にあるテキストボックスに
文字列を入力したら、リスト？が出るようにしたいです。

シート１のA列に名前リストがあり、
そのリストを参照して、1文字入力したら候補が表示されるよう
組みたいと思っています。

シート１
田中　麻美
佐藤　たける
加藤　美佐
佐々木　瞳
竹井　まどか
木村　かりん
木村　ひろし
佐藤　圭
菊地　美優
田中　麻美
佐藤　たける
加藤　美佐
佐々木　瞳
竹井　まどか
木村　かりん
木村　ひろし
佐藤　圭
菊地　美優

-------------
上記のようなリストがあったとします。
（リスト内で必ず重複します。）

木　と入力したら、
木村かりん、木村ひろし　という候補が出て欲しいと思っています。

http://d.hatena.ne.jp/language_and_engineering/20081125/1227571724
ワークシート上でのプログラムは
上記リンクを参考にすればできるかとは思うのですが、
フォーム上ではできないでしょうか？

また、コンボボックスならやり方は何となくわかりますが、
どうしても、テキストボックスでやりたいと思っています。
テキストボックスでも可能かどうか、教えて下さい！

回答No.3

mitarashi · ベストアンサー

#1です。更に遊んでいました。テキストボックスをリストに合わせて自動拡張にしてみました。また、意図しない入力への対応を盛り込んでみました。その場しのぎの対応なので、論理的ではないかもしれません。
ADOを使っているので、半角の%を入力すると全リストが表示されます。また、変換しにくいですが%藤とかを入れると、先頭以外もヒットします。
添付画像のCommandButtonはZOrderの試験用です。
Dim listSetFlag As Boolean
Dim lineCount As Long
Const initialHeight As Single = 18
Const lineWidth As Single = 9

Private Sub TextBox1_Change()
Dim myText As String

If Not listSetFlag Then
myText = getUniqueList(Me.TextBox1.Value)
If myText = "" Then
Me.TextBox1.Value = ""
Else
listSetFlag = True
With Me.TextBox1
.Value = myText
.Height = initialHeight + lineWidth * (lineCount - 1)
.SelStart = 1
End With
End If
End If
End Sub

Private Sub TextBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim buf1 As String, buf2 As String
Dim myList As Variant
Dim selectedline As Long

If Me.TextBox1.Value = "" Then Exit Sub
buf1 = Replace(Me.TextBox1.Text, vbCrLf, vbCr) '-A
buf2 = Left(buf1, TextBox1.SelStart)
selectedline = UBound(Split(buf2, vbCr))
myList = Split(buf1, vbCr)
MsgBox "選択されたのは " & myList(selectedline) & "です。"
'initialize
Me.TextBox1.Value = ""
Me.TextBox1.Height = initialHeight
lineCount = 0
listSetFlag = False
End Sub

Private Sub UserForm_Initialize()
With Me.TextBox1
.MultiLine = True
.WordWrap = False
.ZOrder fmZOrderFront
.IMEMode = fmIMEModeOn
.Height = initialHeight
End With
listSetFlag = False
lineCount = 0
End Sub

Function getUniqueList(key As String) As String
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim mySQL As String

If key = "" Then
getUniqueList = ""
Exit Function
End If
Set cn = New ADODB.Connection
'xl2007以降対応です。2003以前は、自ワークブックへの接続に関してメモリリークの問題が
'改善されていないので、別の方法をとるべきでしょう。
With cn
.Provider = "Microsoft.ace.OLEDB.12.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties='Excel 12.0; HDR=Yes'" '見出し無しの時はここをNoに
.Open
End With
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
'見出し無しの時はここの氏名に代えてF1を入れる
mySQL = Replace("select distinct 氏名 from [Sheet1$] where 氏名 like 'key%';", "key", key)
rs.Open mySQL, cn, adOpenDynamic
lineCount = rs.RecordCount
If lineCount > 0 Then
'改行をvbCrやvbLfで行っても動く（Aの文字数調整不要となる）が、変にちらつく
getUniqueList = rs.GetString(adClipString, , , vbCrLf)
Else
MsgBox "みつかりません"
getUniqueList = ""
End If
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
End Function

お礼

回答ありがとうございます！
返信おくれて申し訳ありません。

おぉお、すばらしい機能が…！
ありがとうございます！
試してみます＾＾

回答No.2

mitarashi

#1です
肝腎なことを書き落としていました。
Sheet1のリストの一行目には「氏名」という見出しを入れておいて下さい。
入れない場合でも対応は可能ですが、分かり易い方策をとっています。
失礼致しました。

お礼

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

回答No.1

mitarashi

>どうしても、テキストボックスでやりたいと思っています。
こういうこだわりの世界はご自分で解決する方が楽しいと思いますが、試しにやってみました。
あくまで考え方の例として好き放題やっておりますので、質問者様の環境に合わないかもしれませんが、ご了解願います。

UserFormにTextBoxを一個だけ置いています。高さはリスト表示に必要なだけ確保して下さい。ADOに参照設定が必要です。likeで抽出しているので、「佐」でも「佐藤」でも抽出可能です。
Dim listSetFlag As Boolean

Private Sub TextBox1_Change()
If Not listSetFlag Then
listSetFlag = True
Me.TextBox1.Value = getUniqueList(Me.TextBox1.Value)
End If
End Sub

Private Sub TextBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim buf1 As String, buf2 As String
Dim myList As Variant
Dim selectedline As Long

If Me.TextBox1.Value = "" Then Exit Sub
buf1 = Replace(Me.TextBox1.Text, vbCrLf, vbCr) '-A
buf2 = Left(buf1, TextBox1.SelStart)
selectedline = UBound(Split(buf2, vbCr))
myList = Split(buf1, vbCr)
MsgBox "選択されたのは " & myList(selectedline) & "です。"
Me.TextBox1.Value = ""
listSetFlag = False
End Sub

Private Sub UserForm_Initialize()
Me.TextBox1.MultiLine = True
Me.TextBox1.WordWrap = False
listSetFlag = False
End Sub

Function getUniqueList(key As String) As String
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim startTime As Long
Dim mySQL As String

Set cn = New ADODB.Connection
'xl2007以降対応です。2003以前は、自ワークブックへの接続に関してメモリリークの問題が
'改善されていないので、別の方法をとるべきでしょう。
With cn
.Provider = "Microsoft.ace.OLEDB.12.0"
.ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties='Excel 12.0; HDR=Yes'"
.Open
End With
Set rs = New ADODB.Recordset
mySQL = Replace("select distinct 氏名 from [Sheet1$] where 氏名 like 'key%';", "key", key)
rs.Open mySQL, cn, adOpenDynamic
'改行をvbCrやvbLfで行っても動く（Aの文字数調整不要となる）が、変にちらつく
getUniqueList = rs.GetString(adClipString, , , vbCrLf)
rs.Close: Set rs = Nothing
cn.Close: Set cn = Nothing
End Function

お礼

回答ありがとうございます！
参考に頑張ります＾＾