Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


9662 / 13646 ツリー ←次へ | 前へ→

【26119】コンボボックスの補完機能 05/6/23(木) 22:48 質問[未読]
【26124】Re:コンボボックスの補完機能 ichinose 05/6/24(金) 1:24 発言[未読]
【26171】Re:コンボボックスの補完機能 05/6/25(土) 14:57 質問[未読]
【26180】Re:コンボボックスの補完機能 ichinose 05/6/25(土) 21:22 発言[未読]
【26183】Re:コンボボックスの補完機能 05/6/25(土) 22:54 お礼[未読]
【26178】Re:コンボボックスの補完機能 ponpon 05/6/25(土) 20:29 発言[未読]
【26184】Re:コンボボックスの補完機能 05/6/25(土) 22:55 発言[未読]

【26119】コンボボックスの補完機能
質問    - 05/6/23(木) 22:48 -

引用なし
パスワード
   ワークシートに、コンボボックスを1つ作りました。
そのコンボボックスには、A1〜A5のセルのリストが入っていて、
A1〜A5の中身はそれぞれ、愛、アイス、書く、隠す、かくれんぼ、というものにしました。
コンボボックスに、「かく」と入れて確定すると、かくれんぼが出てきます。
この補完機能を消すには、どうしたら良いのでしょうか?
後、あ、と入れるだけで(確定させずに)、あから始まる言葉(この場合は愛とアイス)がドロップダウンするようには出来るのでしょうか?
同様に、かと入れると、書く、隠す、かくれんぼの3つがドロップダウンするようにしたいんですが・・・。
どなたか教えて下さい><

【26124】Re:コンボボックスの補完機能
発言  ichinose  - 05/6/24(金) 1:24 -

引用なし
パスワード
   ▼氷 さん:
こんばんは。

>ワークシートに、コンボボックスを1つ作りました。
>そのコンボボックスには、A1〜A5のセルのリストが入っていて、
>A1〜A5の中身はそれぞれ、愛、アイス、書く、隠す、かくれんぼ、というものにしました。
>コンボボックスに、「かく」と入れて確定すると、かくれんぼが出てきます。
>この補完機能を消すには、どうしたら良いのでしょうか?
>後、あ、と入れるだけで(確定させずに)、あから始まる言葉(この場合は愛とアイス)がドロップダウンするようには出来るのでしょうか?
>同様に、かと入れると、書く、隠す、かくれんぼの3つがドロップダウンするようにしたいんですが・・・。
>どなたか教えて下さい><

以下のコードをコンボボックスを作成したシートの
シートモジュールに貼り付けてください。

尚、コンボボックス名はCombobox1とします
違う名前なら、コードを変更して下さい。

'=============================================================
Dim ev As Long 'Changeイベントの有無フラグ 0--発生可能 その他---発生不可
'======================================================================
Sub settei()
  ev = 1
  With ComboBox1
   .ListFillRange = ""
   .MatchEntry = fmMatchEntryNone
   .Style = fmStyleDropDownCombo '←これは事前設定でよいです
   .Text = ""
   .Clear
   
   End With
  ev = 0
End Sub
'=====================================================================
Private Sub ComboBox1_Change()
  Dim svtext As String 'コンボボックスのTextの内容の一時保存
  Dim rng As Range
  If ev > 0 Then Exit Sub
  Set rng = Range("a1", Cells(Rows.Count, 1).End(xlUp))
  With ComboBox1 '←適当な名前に変更すること
   svtext = .Text
   If .Text <> "" Then
     If rng.Count = 1 Then
      If rng.Value = "" Then
        .Clear
        Exit Sub
        End If
      End If
     myvalue = get_match_array(rng, .Text)
     TypeName (myvalue)
     ev = 1
     .Clear
     If TypeName(myvalue) <> "Integer" Then
      .List() = myvalue
      .DropDown
      End If
     .Text = svtext
     ev = 0
   Else
     ev=1
     .Clear
     .Visible = False
     .Visible = True
     .Activate
     ev=0
     End If
   End With
End Sub
'===============================================================
Function get_match_array(rng As Range, ByVal f_str)
'f_strの内容とセル範囲(rng)の値とフリガナを検索し、どちらかが部分一致した
'セルの内容を配列と出力する
  Dim myarray()
  Dim crng As Range
  Dim cnt As Long
  f_str = StrConv(f_str, vbHiragana)
  cnt = 0
  For Each crng In rng
   If f_str = Mid(StrConv(crng.Text, vbHiragana), 1, Len(f_str)) Or _
    f_str = Mid(StrConv(crng.Phonetic.Text, vbHiragana), 1, Len(f_str)) Then
    ReDim Preserve myarray(1 To cnt + 1)
    myarray(cnt + 1) = crng.Text
    cnt = cnt + 1
    End If
   Next crng
  If cnt > 0 Then
   get_match_array = myarray()
  Else
   get_match_array = 0
   End If
End Function


コンボボックスの入力を行う前に一度だけ、
setteiというプロシジャーを実行して下さい。

「ツール」---「マクロ」とクリックすれば、

「シート名!settei」というマクロ名が表示されるはずですから

選択して実行して下さい

その後で対象となるコンボボックスに入力して試してみて下さい。

確認して下さい。

【26171】Re:コンボボックスの補完機能
質問    - 05/6/25(土) 14:57 -

引用なし
パスワード
   ichinoseさんご返信ありがとうございます<(_ _)>
コンボボックスが1つの場合は出来たのですが、実はこれと同じ処理を4つ(参照するセルもバラバラ(a1〜d1))のときの処理が出来ないんです><
2つの場合を試したのですが、どこを改善する必要があるのでしょうか?

コードを以下に示します。(長いですが^^;)


'=============================================================
Dim ev As Long 'Changeイベントの有無フラグ 0--発生可能 その他---発生不可
Dim ev2 As Long


'======================================================================
Sub settei1()
  ev = 1
  With ネーム
   .ListFillRange = ""
   .MatchEntry = fmMatchEntryNone
   .Style = fmStyleDropDownCombo '←これは事前設定でよいです
   .Text = ""
   .Clear
 
   End With
  ev = 0
End Sub
'=====================================================================
Private Sub ネーム_Change()
  Dim svtext As String 'コンボボックスのTextの内容の一時保存
  Dim rng As Range
  If ev > 0 Then Exit Sub
  Set rng = Range("a1", Cells(Rows.Count, 1).End(xlUp))
  With ネーム '←適当な名前に変更すること
   svtext = .Text
   If .Text <> "" Then
     If rng.Count = 1 Then
      If rng.Value = "" Then
        .Clear
        Exit Sub
        End If
      End If
     myvalue = get_match_array(rng, .Text)
     TypeName (myvalue)
     ev = 1
     .Clear
     If TypeName(myvalue) <> "Integer" Then
      .List() = myvalue
      .DropDown
      End If
     .Text = svtext
     ev = 0
   Else
     ev = 1
     .Clear
     .Visible = False
     .Visible = True
     .Activate
     ev = 0
     End If
   End With
End Sub
'===============================================================
Function get_match_array(rng As Range, ByVal f_str)
'f_strの内容とセル範囲(rng)の値とフリガナを検索し、どちらかが部分一致した
'セルの内容を配列と出力する
  Dim myarray()
  Dim crng As Range
  Dim cnt As Long
  f_str = StrConv(f_str, vbHiragana)
  cnt = 0
  For Each crng In rng
   If f_str = Mid(StrConv(crng.Text, vbHiragana), 1, Len(f_str)) Or _
    f_str = Mid(StrConv(crng.Phonetic.Text, vbHiragana), 1, Len(f_str)) Then
    ReDim Preserve myarray(1 To cnt + 1)
    myarray(cnt + 1) = crng.Text
    cnt = cnt + 1
    End If
   Next crng
  If cnt > 0 Then
   get_match_array = myarray()
  Else
   get_match_array = 0
   End If
End Function


Sub settei2()
  ev2 = 1
  With コード
   .ListFillRange = ""
   .MatchEntry = fmMatchEntryNone
   .Style = fmStyleDropDownCombo '←これは事前設定でよいです
   .Text = ""
   .Clear
 
   End With
  ev2 = 0
End Sub
'=====================================================================
Private Sub コード_Change()
  Dim svtext As String 'コンボボックスのTextの内容の一時保存
  Dim rng As Range
  If ev2 > 0 Then Exit Sub
  Set rng = Range("b1", Cells(Rows.Count, 1).End(xlUp))
  With コード '←適当な名前に変更すること
   svtext = .Text
   If .Text <> "" Then
     If rng.Count = 1 Then
      If rng.Value = "" Then
        .Clear
        Exit Sub
        End If
      End If
     myvalue = get_match_array_2(rng, .Text)
     TypeName (myvalue)
     ev2 = 1
     .Clear
     If TypeName(myvalue) <> "Integer" Then
      .List() = myvalue
      .DropDown
      End If
     .Text = svtext
     ev2 = 0
   Else
     ev2 = 1
     .Clear
     .Visible = False
     .Visible = True
     .Activate
     ev2 = 0
     End If
   End With
End Sub

'===============================================================
Function get_match_array_2(rng As Range, ByVal f_str)
'f_strの内容とセル範囲(rng)の値とフリガナを検索し、どちらかが部分一致した
'セルの内容を配列と出力する
  Dim myarray()
  Dim crng As Range
  Dim cnt As Long
  f_str = StrConv(f_str, vbHiragana)
  cnt = 0
  For Each crng In rng
   If f_str = Mid(StrConv(crng.Text, vbHiragana), 1, Len(f_str)) Or _
    f_str = Mid(StrConv(crng.Phonetic.Text, vbHiragana), 1, Len(f_str)) Then
    ReDim Preserve myarray(1 To cnt + 1)
    myarray(cnt + 1) = crng.Text
    cnt = cnt + 1
    End If
   Next crng
  If cnt > 0 Then
   get_match_array_2 = myarray()
  Else
   get_match_array_2 = 0
   End If
End Function

【26178】Re:コンボボックスの補完機能
発言  ponpon  - 05/6/25(土) 20:29 -

引用なし
パスワード
   こんばんは。

http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=25980;id=excel

こちらの方は、どうなりましたか?

【26180】Re:コンボボックスの補完機能
発言  ichinose  - 05/6/25(土) 21:22 -

引用なし
パスワード
   ▼氷 さん:
こんにちは。
再投稿です。
>コンボボックスが1つの場合は出来たのですが、実はこれと同じ処理を4つ(参照するセルもバラバラ(a1〜d1))のときの処理が出来ないんです><
投稿されたコードを拝見すると大きい間違いはわかりました。

でもね、氷 さんはもう既に何度かここに質問をされていますよね?
今後の事もありますから敢えて申し上げますが、
投稿されたコードで出来ない時の現象(こんなエラーメッセージが表示される等)を
記述するようにして下さいね!!

同じような処理をするコンボボックスが増えるようなら
別の方法も考えなければなりませんが、
4つ程度の個数なら以下のようなコードでよいかと思います。
大きく前回とコードを変更しました。

対象となっているシートのシートモジュールに

'===================================
Sub settei()
'このプロシジャーは、例の
'>コンボボックスに、「かく」と入れて確定すると、かくれんぼが出てきます。
'をしないための設定
'や
'事前に氷 さんがListFillRangeにセル範囲を設定されいる事を
'想定して記述したコードです。
'一度だけ設定していただければ結構です。
'もっと言えば、ここで設定してる事はコンボボックスのプロパティの設定で
'可能です。
  With ネーム
   .ListFillRange = ""
   .MatchEntry = fmMatchEntryNone
   .Style = fmStyleDropDownCombo
   End With
  With コード
   .ListFillRange = ""
   .MatchEntry = fmMatchEntryNone
   .Style = fmStyleDropDownCombo
   End With
  ev = 0
End Sub
'======================================================
Private Sub ネーム_Change()
  Dim rng As Range
  Set rng = Range("a1", Cells(Rows.Count, 1).End(xlUp))
 Call set_combobox(ネーム, rng)
End Sub
'=======================================================
Private Sub ネーム_GotFocus()
  ネーム_Change
End Sub
'========================================================
Private Sub コード_Change()
  Dim rng As Range
  Set rng = Range("b1", Cells(Rows.Count, 2).End(xlUp))
  Call set_combobox(コード, rng)
End Sub
'=========================================================
Private Sub コード_GotFocus()
  コード_Change
End Sub
'=========================================================
Sub set_combobox(cmb As MSForms.ComboBox, rng As Range)
  Dim myvalue As Variant
  With cmb
   If .Text <> "" Then
     If rng.Count = 1 Then
      If rng.Value = "" Then
        .List = Array()
        Exit Sub
        End If
      End If
     myvalue = get_match_array(rng, .Text)
     .List() = Array()
     If TypeName(myvalue) <> "Integer" Then
      .List() = myvalue
      .DropDown
      End If
   Else
    
     .List() = Array()
     .SelStart = 0
     End If
   End With
End Sub
'==========================================================
Function get_match_array(rng As Range, ByVal f_str)
  Dim myarray()
  Dim crng As Range
  Dim cnt As Long
  f_str = StrConv(f_str, vbHiragana)
  cnt = 0
  For Each crng In rng
   If f_str = Mid(StrConv(crng.Text, vbHiragana), 1, Len(f_str)) Or _
    f_str = Mid(StrConv(crng.Phonetic.Text, vbHiragana), 1, Len(f_str)) Then
    ReDim Preserve myarray(1 To cnt + 1)
    myarray(cnt + 1) = crng.Text
    cnt = cnt + 1
    End If
   Next crng
  If cnt > 0 Then
   get_match_array = myarray()
  Else
   get_match_array = 0
   End If
End Function

コンボボックスのClearメソッドを使用していたので
イベントの再発生を防ぐコードにしていましたが、
Textプロパティをコードで変更する必要性がないので上記のように
しました。

コンボボックスを増やす場合は、ChangeイベントとGotfocusイベントの
追加で可能かと思います。
ChangeイベントとGotfocusイベントのどこを変更するかは
上記のコードを見て試して下さい。

【26183】Re:コンボボックスの補完機能
お礼    - 05/6/25(土) 22:54 -

引用なし
パスワード
   ichinose さん、いつもありがとうございます

>でもね、氷 さんはもう既に何度かここに質問をされていますよね?
>今後の事もありますから敢えて申し上げますが、
>投稿されたコードで出来ない時の現象(こんなエラーメッセージが表示される等)を
>記述するようにして下さいね!!

以後気をつけます。本当に申し訳ありませんでした。

ichinose さんのおかげで、何とかできそうです。ありがとうございました^^

【26184】Re:コンボボックスの補完機能
発言    - 05/6/25(土) 22:55 -

引用なし
パスワード
   すみません><
ご好意でお返事して下さってるのに、大変失礼なことをしてしまって申し訳ありませんでした><

9662 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free