カテゴリー: WIN関連

お手伝いの仕事？を楽にするため，また，簡単な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