月: 2023年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