| |
▼氷 さん：
こんにちは。
再投稿です。
>コンボボックスが１つの場合は出来たのですが、実はこれと同じ処理を４つ（参照するセルもバラバラ（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イベントのどこを変更するかは
上記のコードを見て試して下さい。
|
|
ichinose
- 05/6/25(土) 21:22 -
