カテゴリー: ＶＢＡ

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

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

－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」（マクロ有効ブック）でもよかったの
　かも。
　この設定は、以前のものにはなかったような？,気が。
　あったのかな、この辺はちょっと、不確かです。

　お手伝いでしている仕事の内容は、ある行事の参加者申し
　込みの受付の処理です。
　参加希望者は、ＨＰから申し込みをします。すると。手元に
　申し込みのメールが届きます。
　このメールを処理して、

　　１　受講票返信メールの作成・送付
　　　　　受付日付
　　　　　受付Ｎｏ
　　２　受講者一覧表の作成

　の一連の作業をします。以前は、この作業を全部手作業
　でやってました。
　今回の催しの定員が１００名ですから、結構な手間です。
　そこで、ＶＢＡの登場でしたが、やっと次のような手順で
　かなりの部分を半自動？にすることができました。

　
　　送られてくる自動返信メールのコピー(手動）
　　　↓
　　エクセルに貼り付け（手動）
　　　↓
　　必要データーの取り出しと成形（エクセル関数）
　　　↓
　　一覧表への追加（エクセルＶＢＡ）
　　　↓
　　返信文面の作製（エクセル関数）
　　　　受付月日の挿入
　　　　受付Ｎｏの挿入
　　　↓
　　エクセルの返信文面のコピー（手動）
　　　↓
　　メールへの貼り付け（手動）
　　　↓
　　送信・・・・・・・・・受付完了

　これらの作業のなかで、一覧表への追加が一番てまどりまし
　た。
　その次にてまどったのが受付Ｎｏの挿入です。
　これは、受付名簿の一覧表から、追加した項目のＮｏを
　読みとることで実現しました。

　　　Worksheets(“Sheet1”).Range(“B” & Range(“C4”).-
　　　　　　　　End(xlDown).Row).Copy
　　　Range(“J6”).Select
　　　ActiveSheet.Paste

　　表に追加すると、Ｃ４の表題以下のセルに種別が追加され
　ますので、

　　　Range(“C4”).End(xlDown).Row)

　で、どこのセルが記入済みの最下段（行）か取得します。
　この読みとった行とＮｏの書いてある”Ｂ”と＆をとって、
　該当のＮｏのセルの番地を作ってます。

　Worksheets(“Sheet1”).Range(“B” & Range(“C4”).End(xlDown).Row)

　これを、作業セルのＪ６にペーストします。

　　　Range(“J6”).Select
　　　ActiveSheet.Paste

　こんな一連の動作で、受付Ｎｏを挿入した文面を作りました。
　手間取りましたが、ちょっと楽になって、間違いもすくなくなり
　そうです。

　手強いＶＢＡを少しやっつけました。
　以前にしたことを少し思いだしましたが、未だ手強いのには、
　変わりありません。
　昨日、やっつけたのは、一定の範囲のセルを表の最下行に
　追加でペーストするというものです。
　ただ、これだけで、何時間もかかりました。できてみると、

　Sub コピー()
　　　　Worksheets(“Sheet1”).Range(“K133:O133”).Copy
　　　　Worksheets(“Sheet1”).Range(“C” & （Range(“C4”).End(xlDown).Row + 1）).-
　　　　PasteSpecial Paste:=xlPasteValues, -
　　　　Operation:=xlNone, SkipBlanks:=False, Transpose:=False
　　End Sub

　何のことはない、たった、２行です。
　K133～O133のセルに書かれているセルの値だけを、表の
　最下行にコピーするだけです。
　
　表の最下行を

　　　Range(“C4”).End(xlDown).Row

　で求め、その下を＋１で求めます。
　エクセルの番地は、英語と数字です。この番地を

　　　Range(“C” & （Range(“C4”).End(xlDown).Row + 1）)

　で＆を使って作ります。