ユーザーフォーム SetFocus VBA エクセル 検索 (3)

動作の様子です。使ってる名前は,データ作成サイトで作成した架空のものです。

以下,プロシャージャの全文です。

 

 

-ThisWorkbook-
Private Sub Workbook_Open()'************************************************
  Application.OnKey "{F3}",   "BK_clere"
End Sub

このサブは,背景色をクリアーする機能を F3キー に割り当てる部分です。

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  Application.ScreenUpdating = True
End Sub

この部分は,アクティブセルを強調するための記述で,条件付き書式と合わせて設定してます。

-UserForm1-
Dim keyWord As String
Dim myRange As Range
Dim myObj As Range

Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)'***********************************************
  If KeyCode = vbKeyReturn Then
    If ListBox1.ListCount = 0 Then
      UserForm1.TextBox1.SetFocus
      Exit Sub
    Else
     Range(Cells(ListBox1.List(ListBox1.ListIndex, 1), 4).Address).Interior.ColorIndex = 6 (br /)
     'Rangで単一セルを指定の時はaddressが必要
     Cells(ListBox1.List(ListBox1.ListIndex, 1), 4).Select
     Label1.Caption = "検索結果=" & ListBox1.List(ListBox1.ListIndex, 0)
     ListBox1.Clear
     UserForm1.TextBox1.SetFocus
    End If
  End If
  If KeyCode = vbKeyF1 Then
    Range(Cells(ListBox1.List(ListBox1.ListIndex, 1), 4).Address).Interior.ColorIndex = 0
    Cells(ListBox1.List(ListBox1.ListIndex, 1), 4).Select
    Label1.Caption = "検索結果=" & ListBox1.List(ListBox1.ListIndex, 0)
    ListBox1.Clear
    UserForm1.TextBox1.SetFocus
  End If
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)'*************************** 
  Dim K As Integer   
  keyWord = TextBox1.Text

  If KeyCode = vbKeyF1 Then'F1が押されたとき
    ActiveCell.Interior.ColorIndex = 0
    Label1.Caption = "検索結果の削除"
  End If

  If KeyCode = vbKeyReturn Then 'リターンキーが押されたとき
    If keyWord <> "" Then

      K = fukusu_kensaku(keyWord)

      If K > 1 Then
        Label1.Caption = "検索結果=" & "複数該当"
        UserForm1.ListBox1.ListIndex = 0
      Else
        Label1.Caption = "検索結果=" & "一人該当"
        UserForm1.ListBox1.ListIndex = 0
      End If
    UserForm1.TextBox1.Text = ""
    End If

   UserForm1.TextBox1.SetFocus
  End If
End Sub

Private Sub UserForm_Initialize()'************************************************ 
  TextBox1.Text = ""
  With ListBox1
    .ColumnCount = 2
    .ColumnWidths = "120;50"
  End With

  With TextBox1
    .BackColor = RGB(204, 255, 255)
  End With
End Sub

Private Sub UserForm_Activate()'************************************************ 
  UserForm1.TextBox1.SetFocus
End Sub

Private Sub TextBox1_Change()'************************************************ 
  keyWord = TextBox1.Text
End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)'************************************************ 
  With TextBox1
    .BackColor = RGB(255, 255, 255)
  End With
  With ListBox1
    .BackColor = RGB(204, 255, 255)
  End With
End Sub

Private Sub ListBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'*********************************************
  With TextBox1
    .BackColor = RGB(204, 255, 255)
  End With
  With ListBox1
    .BackColor = RGB(255, 255, 255)
  End With
End Sub

Private Sub ListBox1_Change()'***********************
  If ListBox1.ListCount >= 1 Then
    Cells(ListBox1.List(ListBox1.ListIndex, 1), 4).Select
  End If
End Sub

-Module1-
Sub macro2()'***********************
  UserForm1.Show vbModeless
End Sub

Function fukusu_kensaku(key_word As String) As Integer'***********************
  Dim myRange As Range
  Dim myObj As Range
  Dim keyWord As String
  Dim K As Integer
  Set myRange = Range(Range("D2"), Cells(Rows.Count, 4).End(xlUp))
  keyWord = key_word
  Set myObj = myRange.Find(keyWord, LookAt:=xlPart)
  K = 0

  If myObj Is Nothing Then
    MsgBox "'" & keyWord & "'はありませんでした"
    Exit Function
  End If
  Dim msg As String
  Dim myCell As Range
  Set myCell = myObj
  Do
    K = K + 1

    With UserForm1.ListBox1
      .AddItem myCell.Value
      .List(K - 1, 1) = myCell.Row
    End With
    myCell.Offset(0, -3).Value = keyWord & K '■■■■欄外に記入

    Set myCell = myRange.FindNext(myCell)
  Loop While myCell.Row <> myObj.Row

  If K > 1 Then
    UserForm1.ListBox1.SetFocus
    Call SendKeys("{DOWN}")
    Call SendKeys("{UP}")
  End If
  If K = 1 Then
    UserForm1.ListBox1.SetFocus
    Call SendKeys("{Enter}")
  End If
  fukusu_kensaku = K
End Function

Private Sub BK_clere()'***********************
  ActiveCell.Interior.ColorIndex = 0
End Sub

Public Sub SendKeys(Keys As String, Optional Wait As Boolean = False)'***********************
  Static w As Object '// WshShellオブジェクト
// WshShellオブジェクトが生成されていない場合
  If w Is Nothing Then
'// WshShellオブジェクトを生成
    Set w = CreateObject("WScript.Shell")
  End If

  Call w.SendKeys(Keys, Wait)
End Sub