| |
全くコードが違ってしまいますが？
こんなのでも善いかも？
Sheet1、Sheet2共に、Keyが昇順に整列されているなら
'探索値が数値の場合
lngFound = RowSearchBin(Val(.Text), rngBox1, 1)
'探索値が数値の場合
lngFound = RowSearchBin(Val(.Text), rngBox3(Val(Frame1.Tag)), 1)
「RowSearchBin」の最終引数を1にした方が探索が速くなります
尚、Match関数を使用していますので、表の探される値が文字列の時と数値の時で
コードが少し違いますので気を就けて下さい
Option Explicit
Private rngBox1 As Range
Private rngBox3(1 To 3) As Range
Private Sub OptionButton1_Click()
Frame1.Tag = 1
If Not Box3Update Then
TextBox3.SetFocus
End If
End Sub
Private Sub OptionButton2_Click()
Frame1.Tag = 2
If Not Box3Update Then
TextBox3.SetFocus
End If
End Sub
Private Sub OptionButton3_Click()
Frame1.Tag = 3
If Not Box3Update Then
TextBox3.SetFocus
End If
End Sub
Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
Dim lngFound As Long
With TextBox1
If .Text <> "" Then
'探索値が文字列の場合
' lngFound = RowSearchBin(.Text, rngBox1, 0)
'探索値が数値の場合
lngFound = RowSearchBin(Val(.Text), rngBox1, 0)
If lngFound > 0 Then
TextBox2.Text = rngBox1(lngFound, 2)
Else
Beep
MsgBox "該当データが有りません"
Cancel = True
End If
End If
End With
End Sub
Private Sub TextBox3_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If Not Box3Update Then
Cancel = True
End If
End Sub
Private Sub UserForm_Initialize()
Dim i As Long
Dim lngRows As Long
OptionButton1.Value = True
Frame1.Tag = 1
'"Sheet1"のKey列を取得
With Worksheets("Sheet1").Cells(1, "A")
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
Set rngBox1 = .Resize(lngRows)
End With
'"Sheet2"のKey列を取得
For i = 1 To 3
With Worksheets("Sheet2").Cells(1, (i - 1) * 2 + 1)
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
Set rngBox3(i) = .Resize(lngRows)
End With
Next i
End Sub
Private Sub UserForm_Terminate()
Dim i As Long
'"Sheet1"のKey列を取得
Set rngBox1 = Nothing
'"Sheet2"のKey列を取得
For i = 1 To 3
Set rngBox3(i) = Nothing
Next i
End Sub
Private Function RowSearchBin(vntKey As Variant, _
rngScope As Range, _
Optional lngMode As Long = 0) As Long
Dim vntFind As Variant
'Matchによる二分探索
vntFind = Application.Match(vntKey, rngScope, lngMode)
'もし、エラーで無いなら
If Not IsError(vntFind) Then
'もし、Key値と探索位置の値が等しいなら
If vntKey = rngScope(vntFind).Value Then
'戻り値として、行位置を代入
RowSearchBin = vntFind
End If
End If
End Function
Private Function Box3Update() As Boolean
Dim lngFound As Long
Box3Update = True
With TextBox3
If .Text <> "" Then
'探索値が文字列の場合
' lngFound = RowSearchBin(.Text, rngBox3(Val(Frame1.Tag)), 0)
'探索値が数値の場合
lngFound = RowSearchBin(Val(.Text), rngBox3(Val(Frame1.Tag)), 0)
If lngFound > 0 Then
TextBox4.Text = rngBox3(Val(Frame1.Tag))(lngFound, 2)
Else
Box3Update = False
Beep
MsgBox "該当データが有りません"
TextBox4.Text = ""
End If
End If
End With
End Function
|
|
Hirofumi
- 05/10/12(水) 21:56 -
