カテゴリー: ＶＢＡ

間に合わせて作ったVBAが２５日の仕事で役に立ちました。いくつか改良点が必要だったので，改良を加えま
した。やはり，複数検索対応が必要で，アクティブセルを目立たせることも使いやすくするためには必要でし
た。どうしようかと思いましたが，リストボックスと組み合わせることで，懸念だった，検索結果の複数項目
を保持することにしました。

上記のようなユーザーフォームで，検索結果をリストボックスに表示するようにしました。結果が単数の場合
はそのまま選択し，複数の場合は，リストボックスで選択するようにしました。
前回・今回のプロシャージャで，使ったのが，Find(keyWord, LookAt:=xlPart)　というものですが，これ
は，最初にでてきたものしかヒットしません。前回のプロシャージャでは，FindNext(myCell)との組み合わせ
で，あらかじめ複数検索の対象を把握しておいて，複数検索の対象の場合は，別な検索キーで検索するとい
う，手間をかけてました。リストボックを使うことで，検索結果を全部リストボックスに表示することで，プ
ログラム的にはすっきりしました。検索結果が単数の場合は，リストボックスに表示する必要なないのです
が，複数か単数かの判別をする必要が面倒なので，一律リストボックスに表示して，

複数→選択（手動），単数→プログラムで選択

のようにしました。便利な命令があるのもので，今回のプロシャージャ作成で初めて使いましたが，

sendkeys

というもので，キーボードを押した状態をプログラムで作ることができるものです。今回初めてわかりました
が，もし，以前から分かっていたら，以前作ったプロシャージャももっと楽に作れたかもしれないと思います。
次のような動作をします。ここで使ってる名前は，データ用の架空の名前です。

名前を入力して，リターンキーを押すと，検索結果がリストボックスに表示されると同時に，選択されたセル
が見えるようになります。名前のとなりの数字は，その名前ある行番号です。

ここで矢印キーで選択する項目を移動すると，それにつれて，選択状態になったセルが見えるようになりま
す。選択してリターンキーを押すと，該当する名前のセルが選ばれ，背景が黄色になります。

単数の場合は，リストボックスに表示するのですが，表示と同時にリターンキーを送るので，リストボックは
見えず選択されたなまえの背景が黄色になります。文字の背景をその都度変えているのは，どの項目がアク
ティブになるかの表示でデバック用も兼ねてます。

合わせて，上記のように，アクティブセルの色を変えて，他のセルと区別できるようにしてます。次回，操作
の様子と全プロシャージャを掲載します。

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

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

－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

お手伝いの仕事？を楽にするため，また，簡単なVBAを作りました。簡単にできるかと思ったのですが，意外
に難航。なかなか思った動作をしてくれません。意図した動作とは，

のようなユーザーフォームで，クリックをしなくても，テキストボックスに入力できるようにするというもの
です。入力できるようにするには，TextBox1.SetFocus　という表現をするのですが，どう書き換えても入力
できるようになりませんでした。ネットでくぐってもこの　SetFocus　のトラブルは結構あるみたいで，いく
つも出てきますが，明確な解決法には，あたりませんでした。　

最初　Private Sub TextBox1_Change()　というイベントに関係することを記載していましたが，だめでした。

そこで，

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

のイベント処理のところに書いたら，やっと思った動作ができました。
SetFocus　の命令は，どこに書いても正しい動作をするのではない，ということが，おぼろげながら分かりま
した。

思った動作とは，

　ユーザフォームを自動で表示（クリックしなくても，テキストボックスに入力できる状態に）
　入力後所定の動作が終わったら，また，テキストボックスに入力できる状態に

ということで，次のようなコードで，思った動作ができました。

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

やっていることは，単に，テキストボックに検索する文字を入力して，検索後，あれば，あった場所の左側の
背景の色を変えるということで，なんのことはありません。エンターキーを押すと，検索して，F1　を押すと
直前に変えた背景をもとに戻すという，単純な動作です。

ただ，今回のものは，検索の対象が，複数ある場合には，対応していません。複数検索に対応させるには，検
索自体はそれほど複雑ではないのですが，背景色を変える対象も複数になるので，それをもとにに戻すとなる
と，背景を変えた場所を何らかの形で記憶していないとだめで，プロシャージャが複雑になりますので，今回
はやめようかと思います。

ファイル名を取得するのに、文字列関数を操作して取り出しましたが、一発で取り出せる関数もあるようで
す。
FSO と呼ばれるものを使う方法で、詳細は、諸兄のHPに譲りたいと思いますが,

（fPath は目的のファイルまでのファイル名を含んだフルパス）
　　Dim FSO, PathName As String, FileName As String
　　Set FSO = CreateObject(“Scripting.FileSystemObject”)

　　FileName = FSO.GetFileName(fPath)・・・・・・ファイル名だけを取り出す。
　　PathName = FSO.GetParentFolderName(fPath)・・・・・・パスだけ取り出す。

ただ自分自身（マクロを記載したBOOK）の場合は次のようにして求めるようです。

　　ThisWorkbook.Name・・・・自分自身のファイル名
　　ThisWorkBook.FullName・・・自分自身のフルパス

ちなみに、

　　　FileName = FSO.GetFileName(ThisWorkbook)・・・・エラー

のようにファイル名を求めようとするとエラーになります。VBA　が良く分かっている方ならこんなことなさ
らないのでしょうがまだまだ勉強中の私にとって、ちょっと　？　になります。ただ、下記のようにするとき
ちんとファイル名を求められます。でも、ThisWorkbook.Name　でファイル名を求めることができるので、
意味ないですね。

　　　FileName = FSO.GetFileName(ThisWorkbook.FullName)・・・取得可

ただ、自分自身（マクロが書かれているファイル）のファイル名を求める場面は、それほど多くないかなと思います。

作ったプロシャージャを動かして、シートを選択している様子です。リストボックスのシート名をクリックすると、クリックしたシートに移動します。

どのシートが選ばれたかは、リストボックスの IndexID でわかります。Worksheets( IndexID).Name　で、選択されたシート名を表示できます。それほど使う場面はないかとは思いますが、使う時は、便利な機能のよ
うな気がします。

以下は、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

　　fTyp = “Excelファイル(*.xlsm),*.xlsm,Excelファイル(*.xlsx),*.xlsx,Excelファイル(*.xls),*.xls”
　　prompt = “Excelファイルを選択してください”
　　fPath = Application.GetOpenFilename(fTyp, , prompt)

　　If fPath = False Then
　　　　MsgBox “ファイルが選択されていません。”
　　　　Exit Function
　　End If

　　‘====読み込みのファイル名取り出し====
　　Dim STR As String
　　Dim t_file_name As String

　　STR = StrReverse(fPath)
　　t_file_name = Right(fPath, InStr(STR, “\”) – 1)

　　‘====ファイルを開く処理====
　　Dim Wb As Workbook

　　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

エラー処理２・・・・自分自身を開こうとする。

　　このエラー処理は、自分自身を開くとまずいので、ThisWorkbook.FullName　と　開こうとするファイ
　　ルのフルパスの　fPath　を比較することで、同じなら、「自分自身を開こうとしてます。」のメッセージ
　　を出して、Function 　を抜け出します。

　　If ThisWorkbook.FullName <> fPath Then
　　　　・
　　　　・＊開こうとするファイルとすでに開いているファイルを比較する。
　　　　・
　　Else
　　　　MsgBox “自分自身を開こうとしてます。”
　　　　Exit Function
　　End If

　　次の処理のファイルを比較するに先立ち、開こうとするファイルのファイル名を取り出しておきます。い
　　くつか方法をためしましたが、文字列を編集する方法がいいみたいで、フルパスを文字の後尾から　”￥”　
　　を探してファイル名を取り出します。緑の”￥”を探しだせば、赤のフィル名を取り出せます。

　　　　E:￥VBA開発￥シート選択￥Dummy.xlsx
　　　　　　　　　　　　　　　　　　←←←←←

　　はじめ、InStrRev を使ってみましたが、思った結果がでなかったので（後でわかりました）文字列を反転
　　して、先頭から”￥”の探し出し、その文字のある手前まで切り出して、ファイル名を取得しました。なん
　　と、InStrRev　関数は、後ろから文字を探すのですが、見つけた場所の位置を、後ろから数えた位置では
　　なく、前から数えた位置を返すみたいでした。下記のようにして　 t_file_name　にファイル名を取り込
　　みました。
　　‘====読み込みのファイル名取り出し====
　　 Dim STR As String
　　 Dim t_file_name As String

　　 STR = StrReverse(fPath)
　　 t_file_name = Right(fPath, InStr(STR, “\”) – 1)

エラー処理３・・・・既に開いているファイルを開こうとする。
　　既に開いている　Book数を　Workbooks.Count　で取得して、For　ループの中で、開こうとしている
　　ファイル名と比較し、同名のファイルがあれば、True　を　そうでなければ　False　をセットして判定し
　　ます。開いているファイル名は、Workbooks(i).Name　で取得できます。
　　False の場合だけ（同じファイルがない）,目的のファイルを開き、Call sheets_set(Wb)　で、取得する
　　シート名をユーザーフォームのリストボックスに、セットします。

　　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

お手伝いでしている仕事がらみの作業用に、何年かかけて、VBAのプロシャージャを作成しました。おかげ様で、短い時間でその処理ができるようになりました。

ただ、時々でるエラーを、その都度修正したりしながら、使ってきました。自分で作成したプロシャージャなので、なぜエラーが起こったのか、ちょっと流れを見ればわかるのですが、なるべく直さなくてもいいように、作り直したいなと思ってました。

やっていることは至極簡単なことですが、手作業でやると結構な時間とられるので、どうしても、プロシャージャが必要でした。継ぎ足し継ぎ足ししてきたので、結構な分量のプロシャージャになってしまってますので、全部作り直すことは、なかなかできないのですが、ある作業の一部分だけでも、考えられるエラーについての対処を十分にできるようにしたいなと、手直しをし始めました。

今回、作業の対象にしたので、他のエクセルブックを選択して開き、そのブックのシートを選択する、という部分のプロシャージャです。今日、一日、かかって、ほぼ、できたので、備忘録がてら、記載します。

エラー処理１・・・・存在しないファイルを開こうとする。
　　このエラーの回避は、GetOpenFilename　を使って、それそれのディレクトリーを開いて、これから開こ
　　うとするファイルを選択して開くということで、回避しました。ただこの画面で、キャンセルを押してし
　　まうと、「ファイルが選択されてません。」のエラーとなりプロシャージャが中断してしまい、fPath　に
　　　False　がセットされますので、IF 文でFunction　を抜け出すことで、回避しました。

　　‘====読み込みフルパスファイル名の取得====
　　 Dim fPath As Variant
　　 Dim fType, prompt As String

　　 fTyp = “Excelファイル(*.xlsm),*.xlsm,Excelファイル(*.xlsx),*.xlsx,Excelファイル(*.xls),*.xls”
　　 prompt = “Excelファイルを選択してください”
　　 fPath = Application.GetOpenFilename(fTyp, , prompt)

　　 If fPath = False Then
　　 　　MsgBox “ファイルが選択されていません。”
　　 　　Exit Function
　　 End If

　VBAと格闘をしていて、最後に保存しようと、「Crtl+S」を押して
　上書き保存をしようと思うと、なぜか、名前をつけて保存に
　なってしまいます。
　NETで検索してもひっかかりません。
　もしやと思い、ファイル－オプションをたどってみると、なんと
　「保存」という項目があるではありませんか。

　ここにブックの保存形式という覧があります。ここがデフォルトでは、
　マクロを保存しない、「.xlsx」になってます。これで、上書きではなく
　て、名前をつけて保存になったようです。
　ここを、マクロも記録できる、「.xltm」にすると上書きができるよう
　になりました。
　もしかして、ここは、「.xlsm」（マクロ有効ブック）でもよかったの
　かも。
　この設定は、以前のものにはなかったような？,気が。
　あったのかな、この辺はちょっと、不確かです。