-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
Dim keyWord As String
Dim myRange As Range
Dim myObj As Range
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Set myRange = Range("D5:D98")
keyWord = TextBox1.Text
If KeyCode = vbKeyReturn Then
Set myObj = myRange.Find(keyWord, LookAt:=xlPart)
Label1.Caption = "検索結果=「" & myObj.Offset(0, 0).Value & "」" & myObj.Row & "行目"
myObj.Offset(0, -3).Interior.ColorIndex = 6
UserForm1.TextBox1.Text = ""
UserForm1.TextBox1.SetFocus
End If
If KeyCode = vbKeyF1 Then
myObj.Offset(0, -3).Interior.ColorIndex = 0
Set myObj = Nothing
Label1.Caption = "検索結果="
UserForm1.TextBox1.Text = ""
UserForm1.TextBox1.SetFocus
End If
End Sub
Private Sub UserForm_Initialize()
TextBox1.Text = ""
End Sub
Private Sub UserForm_Activate()
UserForm1.TextBox1.SetFocus
End Sub
Private Sub TextBox1_Change()
keyWord = TextBox1.Text
End Sub
以下は、VBA 標準モジュールに記載したプロシャージャです。
Sub ボタン2_Click() は、シートに貼り付けてある、マクロ起動用のものです。
Function sheets_set(Wb As Workbook) の中身は、本来ユーザーフォームの _Initialize()の項目に記入すべきでしょうが、Wb の引き渡し方法がわからないので、こちらに書きました。
--------------- Sub ボタン2_Click() Call Select_sheet End Sub
--------------- Function Select_sheet() ‘====読み込みフルパスファイル名の取得==== Dim fPath As Variant Dim fType, prompt As String
If ThisWorkbook.FullName <> fPath Then If fPath <> “” Then
For i = 1 To Workbooks.Count If Workbooks(i).Name = t_file_name Then BookFlag = True End If Next i
If BookFlag <> True Then MsgBox “ファイルを開きます。” Set Wb = Workbooks.Open(fPath, UpdateLinks:=Ture, ReadOnly:=Ture)
Call sheets_set(Wb) UserForm1.Show vbModeless Else MsgBox “すでに開いているファイルを開こうとしてます。” Exit Function End If End If Else MsgBox “自分自身を開こうとしてます。” Exit Function End If End Function
------------------------------------------- Function sheets_set(Wb As Workbook) Dim i As Integer
With UserForm1.ListBox1 ‘一つだけ選択 .MultiSelect = fmMultiSelectSingle End With
For i = 1 To Wb.Worksheets.Count UserForm1.ListBox1.AddItem (Wb.Worksheets(i).Name) Next
UserForm1.ListBox1.ListIndex = 0 End Function
以下は、ユーザーフォームの方に記載したものです。
------------------------- Private Sub CommandButton1_Click() ThisWorkbook.Activate Unload UserForm1 End Sub
------------------------- Private Sub ListBox1_Click() sh_name = ListBox1.List(ListBox1.ListIndex) TextBox1.Text = sh_name Worksheets(sh_name).Activate End Sub
---------------------------------------------- Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = vbKeyReturn Then KeyCode = 0 ThisWorkbook.Activate Unload Me End If End Sub
---------------------------------------------- Private Sub UserForm_Initialize() With ListBox1 ‘一つだけ選択 .MultiSelect = fmMultiSelectSingle End With End Sub
はじめ、InStrRev を使ってみましたが、思った結果がでなかったので(後でわかりました)文字列を反転 して、先頭から”¥”の探し出し、その文字のある手前まで切り出して、ファイル名を取得しました。なん と、InStrRev 関数は、後ろから文字を探すのですが、見つけた場所の位置を、後ろから数えた位置では なく、前から数えた位置を返すみたいでした。下記のようにして t_file_name にファイル名を取り込 みました。 ‘====読み込みのファイル名取り出し==== Dim STR As String Dim t_file_name As String