Excel VBA質問箱 IV

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

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


51845 / 76732 ←次へ | 前へ→

【29742】Re:フレームについてお聞きしたいのですが
回答  Hirofumi  - 05/10/12(水) 21:56 -

引用なし
パスワード
   全くコードが違ってしまいますが?
こんなのでも善いかも?

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
0 hits

【29736】フレームについてお聞きしたいのですが masa 05/10/12(水) 20:46 質問
【29737】Re:フレームのOptionButtonの値によりマク... かみちゃん 05/10/12(水) 20:57 回答
【29738】Re:フレームのOptionButtonの値によりマク... masa 05/10/12(水) 21:11 お礼
【29742】Re:フレームについてお聞きしたいのですが Hirofumi 05/10/12(水) 21:56 回答
【29756】Re:フレームについてお聞きしたいのですが masa 05/10/13(木) 7:28 お礼
【29744】Re:フレームについてお聞きしたいのですが りん 05/10/12(水) 22:02 発言

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