| |
ichinoseさんご返信ありがとうございます＜（＿ ＿）＞
コンボボックスが１つの場合は出来たのですが、実はこれと同じ処理を４つ（参照するセルもバラバラ（a1〜d1））のときの処理が出来ないんです＞＜
２つの場合を試したのですが、どこを改善する必要があるのでしょうか？
コードを以下に示します。（長いですが＾＾；）
'=============================================================
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
|
|
氷
- 05/6/25(土) 14:57 -
