日付セルクリック時に自作カレンダーフォームを呼び出そう | エクセルマクロ(VBA)実践蔵(じっせんぐら)
- エクセルマクロ(VBA)実践蔵 >
- 項目一覧 >
- 日付セルクリック時に自作カレンダーフォームを呼び出そう
日付セルクリック時に自作カレンダーフォームを呼び出そう最終更新日：2023-06-18
まず、書式設定が日付のセルをクリックされたときに、カレンダーフォームが表示されて、入力しやすくなるように考えていきたいと思います。
方法として、一番単純なので、マクロ有効ブック上で作業することです。
次に難易度は上がりますが、通常エクセルファイル(xlsx)で使用することも考えてみます。
マクロ有効ブック上で書式設定が日付のセルをクリックされた場合にカレンダーフォームを呼び出そう
表示させるカレンダー
とりあえず、ダウンロードという方は、こちら
カレンダーフォームの作成方法はこちらを参照してください。ただ、カレンダーフォームを表示しつづけてしまうので、myLabelClass⁽⁾の最後、CalenderForm.Hideがコメントアウトされているのは、先頭の'を削除してください。今回のケースでは、日付を一つ選択したら、Hideメソッドが実行されて、カレンダーフォームは見えなくなる動作が正しくなります。
クリックされたセルの書式が日付かを判定する
以下の３通りのトリガがあります。- [1]Worksheet_SelectionChangeイベント
- [2]Worksheet_BeforeDoubleClickイベント
- [3]Workbook_SheetBeforeDoubleClickイベント
いずれか、ひとつの方法を選択してください。
[1]と[2]の違いは、表示されるタイミングが異なります。[1]SelectionChangeイベントは、カーソルがセル上を移動したときに呼び出されます。（矢印キー入力によるセルの移動で、日付セルの場合にカレンダーが表示される。）[2]のBeforeDoubleClickはユーザがダブルクリックをしたときにマクロが呼び出され、日付セルであるかを判定する。
[1][2]はどちらも、有効なのはマクロを記述するシートオブジェクトのみで有効となる。
[3]は、[2]と同様で、ユーザがダブルクリックをしたときにマクロが呼び出され、日付セルであるかを判定する。対象シートがブック内全体となる。
[1]Worksheet_SelectionChangeイベントの場合
下記の処理は、シートオブジェクトに記載します。マクロを記述したシートでしか適応されません。Visual Basic画面にて、適応させたいシート名の裏側にコードを記述してください。動作内容は、選択セルが日付セルの場合にカレンダーを呼び出します。選択セルとは、セルをクリックしたり、タブでセルを移動した際に、選択中になったセルのことです。
'***********************************************************
' SelectionChangeイベント発生時処理(セル選択時)
'
' ・単一セル又は単一結合セルがクリックされた場合に
' フォーマットが日付であれば、カレンダーを表示する
'
' 複数セルが選択された場合、複数の結合セルが選択された場合は
' なにもしない
'***********************************************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' 単一セル又は単一結合セルがクリックされ、
' フォーマットが日付か確認
If IsDateRange(Target) = True Then
'カレンダーフォームの呼び出し
CalenderForm.Show
End If
End Sub
カレンダーを載せているフォームのオブジェクト名がCalenderFormです。
呼び出しているIsDateRangeについては、標準モジュールに記載します。
[2]Worksheet_BeforeDoubleClickイベントの場合
[1]ではカーソル移動だけで、カレンダーフォームが表示されるため、ダブルクリックをトリガに呼び出したい場合は、「Private Sub Worksheet_SelectionChange(ByVal Target As Range)」を「Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)」に変更してください。このとき、引数のCancelには、Trueを設定します。Trueを設定しないと、カレンダーフォームから対象セルへ日付の記入ができません。（関数内部は、[3]のコードと同一です）
[3]Workbook_SheetBeforeDoubleClickイベントの場合
「シートオブジェクト」ではなく、「ブックオブジェクト」ThisWorkBookに「Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)」メソッドとして、記述するとマクロ有効ブック内で全シートを対象に日付セルのダブルクリック時に呼び出すことが可能です。マクロ有効ブック上での操作であれば、それほど、コード量も多くないため、こちらがおすすめです。
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
' 単一セル又は単一結合セルがクリックされ、
' フォーマットが日付か確認
If IsDateRange(Target) = True Then
'カレンダーフォームから書き込めるようにTrueを設定して、
'ダブルクリック状態を解除する
Cancel = True
'カレンダーフォームの呼び出し
CalenderForm.Show vbModeless
End If
End Sub
標準モジュールに下記を記載します。
' ********************************************************
' ・単一セル又は単一結合セルを指定された場合に
' フォーマットが日付であれば、Trueを返す
'
' 複数セルが選択された場合、複数の結合セルが選択された場合は
' Falseを返す
' ********************************************************
Function IsDateRange(ByVal t_cell As Range) As Boolean
'初期値(日付でない)を設定
IsDateRange = False
If t_cell.MergeCells Or t_cell.CountLarge = 1 Then
'単一結合セル 又は 単一セル
With t_cell.Cells(1, 1)
'結合セルの場合、左上のセルアドレスが対象
'単一セルの場合、そのセルアドレスが対象
If .Text = "" And .Formula = "" Then
'選択されたセルに値が設定されていない場合
'値を仮入力する
.Value = 1
If IsDate(.Text) = True Then
'仮入力した値が、日付データとして扱われた場合
'仮入力した値を消去
.Value = ""
'日付セルを設定
IsDateRange = True
Else
'仮入力した値を消去
.Value = ""
End If
ElseIf .Formula = "" Or IsNumeric(.Formula) = True Or IsDate(.Formula) = True Then
'選択されたセルに既にデータが設定されている場合
If IsDate(.Text) = True Then
'日付の場合
'日付セルを設定
IsDateRange = True
End If
Else
End If
End With 't_cell.Cells(1, 1)
Else
End If
End Function
標準モジュール側 日付セルの判定(IsDateRange) - イベントからの呼び出し
日付セルが選択されたかを判定する関数です。複数セル・複数の結合セルが引数のRange Objectとして渡された場合は、Falseになります。また、セルに計算式が設定されている場合も、Falseとしています。
RangeオブジェクトのMergeCellsは、単一の結合セルの場合に限り、True となります。
セルの書式設定をFormat関数から取得することもできますが、日付フォーマットにはパターンがあるため、IsDate関数を使用しました。空欄のセルでは使用できないため、値を仮入力して、日付として扱われたかを確認しています。
セルに数式が含まれているセルに対して、値を入力したい場合は、数式(Formula)のバックアップをとり、仮入力後に戻すこともできると思いますが、ここでは、クリックミスとしてFalseを返すようにしています。
日付が記述されている場合、Formulaに日付数値が含まれるため、Formulaが数値のみの場合は、日付かどうかの確認を行っています。
マクロ有効エクセルファイルのダウンロード
使い方：コンテンツの有効化を行う。
マクロの有効化手順については、こちらも参考にしてください。
使い方：作業するシートをこのファイル内で追加又は通常エクセルファイルから移動させる。
ThisWorkBookオブジェクトのWorkbook_SheetBeforeDoubleClickイベントから動作するため、このマクロ有効ファイル内であれば、あとから追加するシートも対象となります。
ダブルクリックしたセルの書式設定が日付の場合に、カレンダーフォームを表示する。
追加の提案として、マクロ有効ブックを保存するとき、同じ場所に同じ名前の標準ファイル(*.xlsx)を作成するを追記しています。以下のダウンロード版には含まれていません。必要であれば、取り込んでください。
日付セルクリックでカレンダーフォームを表示マクロ有効ファイル(xlsm)のダウンロード
「祝日表示対応版」日付セルクリックでカレンダーフォームを表示マクロ有効ファイル(xlsm)のダウンロード
通常エクセルファイルについて考える
エクセルのマクロ有効ブックは、ローカルな環境でのやりとりには問題ありませんが、外部の人とやりとりするには向きません。そこで、下記の２通りについて、考えてみました。
まったく同じシートを共有できるなら下の方が早いと思います。
マクロ有効ブックからシートをまとめて移動して別ブックへ保存する
作業をマクロ有効ブック上で行い、結果シートを別ブック(標準エクセルファイル(*.xlsx))へ移動して保存する方法を考えます。
複数シートをまとめて別ブックへ保存するマクロをこちらに記述しました。
このページの、日付セルクリックでカレンダーフォームを表示マクロ有効ファイル(xlsm)と組み合わせてみてください。
マクロ有効ブックを保存するとき、同じ場所に同じ名前の標準ファイル(*.xlsx)を作成する
下記のコードをThisWorkbookに記載する。
'保存後に実行されるマクロ
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
'自分と同じ名前のxlsxファイルを作成して保存する
'既に存在するなら上書き保存する
Dim strName As String
Dim strMName As String
strMName = ThisWorkbook.Name
'標準エクセルファイル名に変更
strName = Replace(ThisWorkbook.Name, ".xlsm", ".xlsx", , , vbTextCompare)
'コード内のSaveAsでイベントが発生しないように抑止
Application.EnableEvents = False
'上書きの警告を表示させないように抑止
Application.DisplayAlerts = False
'標準エクセルファイルの保存
ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & strName, FileFormat:=xlWorkbookDefault
'ファイル名が標準エクセルファイルに代わってしまうため、元に戻す
ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & strMName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
'警告抑止の解除
Application.DisplayAlerts = True
'イベント抑止の解除
Application.EnableEvents = True
End Sub
上記のコードをマクロ有効ブック側に追加すると、保存したときに自動的に標準エクセルファイルも生成されます。まったく同じシートを共有できるならこちらの方が早いと思います。
以降は、以前記述した記事ですが。書き直した結果不要になったマクロです。何かの役に立つかもしれないので、もう少しの間、載せておきます。⁽2023/5/27⁾
通常エクセルファイルについて考える（その２）
上記で、エクセルマクロ有効ブック上では、書式設定が日付のセルをクリックしたときにカレンダーフォームを表示させることができます。
ただ、エクセルのマクロ有効ブックは、ローカルな環境でのやりとりには問題ありませんが、外部の人とやりとりするには向きません。そのため、通常エクセルファイルへの書き出し⁽シートコピー⁾が必要になってきます。（シートオブジェクトに記述されるマクロは通常エクセルファイルへシート移動した際には記述されて見えますが、保存すると消去されます。）
書き出して保存する機能だけをつけてもいいのですが、Worksheet_SelectionChange処理も必要になってくるので、ツールとして、下記のように、通常エクセルファイルから、マクロ有効ブックへシートを移動し、Worksheet_SelectionChangeをコピーし、マクロ有効ブック上で作業を行った後に、元のエクセルファイルへ戻すことを考えていきたいと思います。
先にダウンロードしたい方は、イベントマクロをコピーするマクロ有効ファイルのダウンロードへお進みください。
シート移動手順
- (1)指定されたファイル(xlsx)のシート名一覧を作成
- (2)「シート取り込む」ボタンが押されたら、指定シートをThisWorkBook(マクロ有効ファイル)に取り込み、事前に記述してある「SelectionChangeイベント発生時動作」をコピー
- (3)(1)で読み込んだファイルへシートを移動して保存
複数シートを対象にするとコードが思ったより増えてしまったので、ひとまず、1シートを対象に別ファイルからシートを１枚取り込み、イベントをコピーする。作業が終わったら、元のファイルへ戻すケースにしていこうと思います。
取り込むシートをユーザに選択してもらうために、シート名一覧をセルの入力規則のリストとして表示させます。初期設定として、先頭(左端)のシートを選択中とします。この設定をしておくことで、未選択状態の場合の考慮が不要になります。
(1)に進む前に、前準備となる前述のSelectionChangeイベント処理をテンプレートシート(シート名：temp)に記載します。
(1)指定されたファイル(xlsx)のシート名一覧を作成
エクセルの表側の見た目は以下の通りです。
- セルB9 : ファイルパス
- セルD11 : セルB9で指定されたファイル内のシート名リスト(入力規則をVBコードから設定)
- セルB21：欄外にシート名リストを作成し、入力規則に設定する
ユーザからファイルパスを取得する方法については、ファイル参照 - ファイル選択ダイアログを参照してください。
ユーザにシート名を選択してもらう方法として、セルの入力規則のリストを使用していますが、他の方法として、ActiveXコントロールのリストボックスを使用することもできます。
セルの入力規則リストとActiveXコントロールのリストボックスの違いは、デザイン面とエクセルファイルを閉じて開きなおしたときに、前回選択した値が残るか消えるかの違いになります。セルの入力規則リストはセルの情報として残ります。また、複数の項目を選択したい場合、ActiveXコントロールのリストボックスを使用し、MultiSelect設定でfmMultiSelectMultiを設定します。
シートの裏側(Visual Basic Editor側) - (1)のコード
(1)指定されたファイルのシート名一覧を作成
エクセルシートの固定位置から取得する個所は、モジュール化しておくと、デザインを変更する際の修正漏れを防ぐことができます。
下記のMakeSheetList()は、「ファイル選択」ボタンクリック時のイベント処理内の最後に呼び出すようにしています。
また、動作確認がしやすいように「リストの読み直し」ボタンクリック時のマクロとしても登録しています。
'***********************************************
' エクセルシートの指定セル情報を取得
'***********************************************
Private Function GetFilePathRng() As Range
Set GetFilePathRng = Range("B9")
End Function
Private Function GetInSheetNameRng() As Range
Set GetInSheetNameRng = Range("D11")
End Function
Private Function GetInSheetNameListRng() As Range
Set GetInSheetNameListRng = Range("B21")
End Function
'*************************************************************
' シート名リストと入力規則リストの作成
' シート名リスト作成先は、GetInSheetNameListRngから受け取る
' 入力規則を設定するセルは、GetInSheetNameRngから受け取る
'*************************************************************
Sub MakeSheetList()
Dim ReadBook As Workbook
Dim ReadSheet As Worksheet
Dim FilePathRng As Range
Dim SheetNameRange As Range
Dim SheetNameListRng As Range
Dim cnt As Integer
Dim format As String
'ファイルパスを記載しているRangeを取得
Set FilePathRng = GetFilePathRng
Set SheetnameRng = GetInSheetNameRng
Set SheetNameListRng = GetInSheetNameListRng
'ファイルを開く
Set ReadBook = OpenBook(FilePathRng.Text)
If ReadBook Is Nothing Then
MsgBox "指定ファイルが見つかりません。"
Exit Sub
End If
'Excel2010でエラー処置
' Workbook Open後、マクロを動作させているシートを
' Activeに戻す
Me.Activate
'前のデータを削除するため、初期化する
'入力規則をクリア
SheetnameRng.Validation.Delete
'入力規則セルの値をクリア
SheetnameRng.Value = ""
'リストを初期化
Call ClearRange(SheetNameListRng, "Row")
'シート名リストを作成する
cnt = 1
For Each ReadSheet In ReadBook.Worksheets
'リストに追加
SheetNameListRng.Cells(cnt, 1).Value = ReadSheet.Name
'リスト項目の行数を更新
cnt = cnt + 1
Next
'指定セルに入力規則リストを設定する
With SheetnameRng.Validation
.Delete '前の設定を削除
'入力規則リストの参照先を作成
format = "=" & SheetNameListRng.Cells(1, 1).Address & ":" _
& SheetNameListRng.Cells(cnt-1, 1).Address
.Add Type:=xlValidateList, Operator:=xlEqual, Formula1:=format
End With
'入力規則を設定したセルにシート名リスト先頭を設定
SheetnameRng.Value = SheetNameListRng.Value
'シート名を取り込んだブックは一度閉じます
ReadBook.Close
'メモリ解放
Set ReadBook = Nothing
Set ReadSheet = Nothing
Set FilePathRng = Nothing
Set SheetnameRng = Nothing
Set SheetNameListRng = Nothing
End Sub
上記で呼び出しているOpenBook()については、別ページの「別ファイルへシートの複製」を参照してください。
ClearRangeは、標準モジュール側に記載します。
標準モジュール側 - (1)別ファイルのシート名一覧を作成処理
(1)の処理から呼び出されている標準モジュール側に記載した処理を記述していきます。
'*************************************************************
' 第一引数のセルから第二引数("Row" 又は "Column")の方向に
' 向かって、セルの値が入っている限りクリアしていく
' セルに値が入ってなかったら終了する
'*************************************************************
Function ClearRange(targetCell As Range, direction As String)
Dim cnt As Long
cnt = 1
If StrComp(direction, "Row", vbTextCompare) = 0 Then
'指定方向が行の場合
'行の最後まで（空欄になるまで）
For cnt = 1 To targetCell.End(xlDown).Row
If targetCell.Cells(cnt, 1).Value <> "" Then
'値が設定されている
'セルの値を空にする
targetCell.Cells(cnt, 1).Value = ""
Else
'値なし（空欄）の場合
'初期化終了
Exit For
End If
Next
ElseIf StrComp(direction, "Column", vbTextCompare) = 0 Then
'指定方向が列の場合
'列のの最後まで（空欄になるまで）
For cnt = 1 To targetCell.End(xlToRight).Column
If targetCell.Cells(1, cnt).Value <> "" Then
'値が設定されている
'セルの値を空にする
targetCell.Cells(1, cnt).Value = ""
Else
'値なし（空欄）の場合
'初期化終了
Exit For
End If
Next
End If
End Function
(2)指定シートをThisWorkBookに取り込み、「SelectionChangeイベント」をコピー
「シート取り込む」ボタンがクリックされた時の動作になります。
あらかじめ、シート名「temp」の裏側(Visual Basic Editor)にSelectionChangeイベント発生時のマクロコードを記載しておきます。下記で呼び出しているCopySheetMacro()内で、シート裏側のコードを第一引数のシートから第二引数のシートへ全てコピーします。
シートの裏側(Visual Basic Editor) - (2)「シート取り込み」ボタンクリック時動作
'****************************************************
' ファイルをオープンして、リストボックスにて選択された
' シート名をコピーして取り込む
'****************************************************
Private Sub SheetCopyIn_Click()
Dim cnt As Long
Dim sheetName As String
Dim inbook As Workbook
Dim temp_sheet, newSheet As Worksheet
Dim FilePathRng As Range
'ファイルパスを記載しているRangeを取得
Set FilePathRng = GetFilePathRng
'テンプレートシートのSheet Objectを設定
Set temp_sheet = ThisWorkbook.Worksheets("temp")
'ファイルを開く
Set inbook = OpenBook(FilePathRng.Text)
If Not inbook is Nothing And Not SheetListBox.Text = "" then
Me.Activate 'このシートをActiveに変更
'外部ファイルから選択シートを取り込む（コピー）
Set newSheet = CopySheet_BooktoBook(inbook, SheetListBox.Text, ThisWorkbook)
'コピー元：シート名「temp」の裏側(Visual Basic Editor)に記載されているマクロ
'コピー先：外部ファイルから取り込んだシート
'Visual Basic(マクロ)コードをコピーする
Call CopySheetMacro(temp_sheet, newSheet)
inbook.Close
End if
Set inbook = Nothing
Set newSheet = Nothing
Set temp_sheet = Nothing
Set FilePathRng = Nothing
End Sub
上記で呼び出しているGetFilePathRngについては、このページ内のこちらを参照してください。
OpenBook()については、別ページの「別ファイルへシートの複製」を参照してください。CopySheet_BooktoBook()についても、別ページの「別ファイルへシートの複製」を参照してください。
CopySheetMacro()は、標準モジュール側に記載していきます。
UBoundは配列の要素数を返してくれるVisual Basic標準関数です。
標準モジュール側 - (2)のコード
(2)指定シートをThisWorkBookに取り込み、「SelectionChangeイベント」をコピーする（「シート取り込む」ボタンがクリックされた時の動作）から呼び出されるモジュールです。
マクロコードをコピーする関数(CopySheetMacro)については、SelectionChangeイベントに限らず、コピー元シートに記述されているコードをすべて、コピー先シートへコピーしています。イベント名を指定して、「SelectionChangeイベント」限定で追加コピーするコードを記載することも可能ですが、既に存在する場合を考慮するよりは、コピー先が空であれば、全てコピーする処理としています。
'**********************************************************************
' コピー元シートのマクロコードをコピー先シートへコピーする
' コピー元シート：sorceSheet（コードが空なら何もしない）
' コピー先シート：destSheet(コードが空のときにコピーする)
'**********************************************************************
Function CopySheetMacro(sorceSheet As Worksheet, destSheet As Worksheet)
Dim sorceModule, destModule As Object
Dim strCodeLine As String
'VBProjectへアクセス
With ThisWorkbook.VBProject
'コピー元シートのModule Objectを設定
Set sorceModule = .VBComponents(sorceSheet.CodeName).CodeModule
'コピー先シートのModule Objectを設定
Set destModule = .VBComponents(destSheet.CodeName).CodeModule
End With
' コピー元にコードがある場合 かつ コピー先にコードがない場合、又は、
' コピー元にコードがある場合 かつ コピー先に"Option Explicit"のみが記述されている場合
If (sorceModule.CountOfLines > 0 And destModule.CountOfLines = 0) _
Or (sorceModule.CountOfLines > 0 And _
StrComp(destModule.Lines(1, sorceModule.CountOfLines), "Option Explicit" & vbCrLf & vbCrLf, vbBinaryCompare) = 0) Then
' Option Explicit ありの場合 一旦削除
If destModule.CountOfLines > 0 Then
'コピー先を削除
Call destModule.DeleteLines(1, destModule.CountOfLines)
End If
'コピー元のマクロを
strCodeLine = sorceModule.Lines(1, sorceModule.CountOfLines)
'コピー先へすべてコピー
destModule.InsertLines 1, strCodeLine
End If
'メモリの解放
Set sorceModule = Nothing
Set destModule = Nothing
End Function
上記関数では、VBProjectへアクセスする必要があるため、あらかじめ、動作させるためには、エクセルのオプション「セキュリティーセンター」の「セキュリティセンターの設定」のダイアログにある「マクロの設定」の開発者向けのマクロ設定にある「VBAプロジェクトオブジェクトモデルへのアクセスを信頼する」にチェックが入っている必要があります。
ここまでで、取り込んだシートの日付フォーマットのセルをクリックするとカレンダーが表示されるようになります。
(3)(1)で読み込んだファイルへシートを移動して(戻して)保存
シートの表側としては、保存シートを作成し、ファイルパスは、読込シート側のファイルパスを参照しています。(シートを取り込んだときのファイルパス。)新しく「シートを保存」ボタンを作成し、出力するシート名は、このシートが表示されたときに、入力規則リストを作成するようにしています。
保存シートのVisual Basic Editor側(Worksheet_Activate)
保存シートが表示されたときのイベント処理は、Worksheet_Activate()に記載します。但し、ファイルオープン時にこのシートが先頭だった場合、Activateイベントは発生しないため、オープン時のイベント処理で先頭シートが保存シートだった場合、Worksheet_Activate()を呼び出すように処理を追加しています。
'************************************
' エクセルシートの指定セル情報を取得
'************************************
Private Function GetOutFilePathRng() As Range
Set GetOutFilePathRng = Range("B12")
End Function
Private Function GetOutSheetNameRng() As Range
Set GetOutSheetNameRng = Range("D14")
End Function
Private Function GetSheetNameListRng() As Range
Set GetSheetNameListRng = Range("B20")
End Function
'***************************************************************
' 表示シートになったときのイベント処理
' (Book Open時にトップシートだった場合はイベントは発生しない。)
'***************************************************************
Public Sub Worksheet_Activate()
Dim SheetnameRng As Range
Dim FilePathRng As Range
Dim FolderPathRng As Range
Dim SheetListRng As Range
Dim topSheetName As String
Dim defaultSheets() As String
Dim chk_index As Long
Dim list_cnt As Long
Dim target_sheet As Worksheet
Dim checkResult As Boolean
Dim format As String
'シート内の固定Range情報を取得
Set FilePathRng = GetOutFilePathRng
Set SheetnameRng = GetOutSheetNameRng
Set SheetListRng = GetSheetNameListRng
ReDim defaultSheets(3)
'デフォルトシート名を設定
defaultSheets(1) = "読込"
defaultSheets(2) = "保存"
defaultSheets(3) = "temp" ' 非表示シート
list_cnt = 1
'移動可能なシートリストを作成する
For Each target_sheet In ThisWorkbook.Worksheets
'配列内の文字列と一致するか確認
chk_index = StrComp_ArraySt1(defaultSheets, target_sheet.Name)
If chk_index = -1 Then
'一致しない場合(デフォルトシートではない)
'移動可能なシートリストを作成する
SheetListRng.Cells(list_cnt, 1).Value = target_sheet.Name
list_cnt = list_cnt + 1
End If
Next
If list_cnt > 1 Then
'移動可能シートあり
'シート名セルに入力規則を設定する
With SheetnameRng.Validation
.Delete '前の設定を削除
'入力規則リストの参照先を作成
format = "=" & SheetListRng.Cells(1, 1).Address & ":" _
& SheetListRng.Cells(list_cnt - 1, 1).Address
.Add Type:=xlValidateList, Operator:=xlEqual, Formula1:=format
End With
'シート名リスト先頭を出力シート名に設定
SheetnameRng.Value = SheetListRng.Value
Else
'出力シート名セルを初期化
SheetnameRng.Validation.Delete
SheetnameRng.Value = ""
'シートリスト削除
Call ClearRange(SheetListRng, "Row")
End If
End Sub
StrComp_ArraySt1()は標準モジュールに記述します。
Visual Basic Editor側 - ThisWorkBook(Workbook_Open)
ファイルオープン時に保存シートがトップシートだった場合、イベントは発生しないため、オープン時のイベント処理で、保存シートがトップシートだった場合に保存シートのWorksheet_Activate()を呼び出すように処置します。
'******************************
'ファイルオープン時イベント処理
'******************************
Private Sub Workbook_Open()
Dim sheet_name As String
Dim Dammy_Rng As Range
'シートが開くのを待つため
Set Dammy_Rng = ActiveSheet.Range("A1")
'開いているシート名を取得
sheet_name = ActiveSheet.Name
'保存シートの場合
If StrComp(sheet_name, "保存", vbTextCompare) = 0 Then
'アクティブイベント処理を動作させる
Call ActiveSheet.Worksheet_Activate
End If
End Sub
標準モジュール側- 保存シートのWorksheet_Activateから呼ばれる関数
'**************************************************************
' 第二引数の文字列が第一引数の文字列配列内の何番目と一致するか
' を返す。一致しない場合は、-1を返す。
' 配列は、(1)から(配列数)までアクセスする。
'**************************************************************
Function StrComp_ArraySt1(ByRef list_str() As String, _
ByVal chk_str As String) As Long
Dim cnt As Long
'初期値(一致しない)を設定
StrComp_ArraySt1 = -1
'先頭シート名とデフォルトシート名を比較
For cnt = 1 To UBound(list_str)
If StrComp(list_str(cnt), chk_str, vbTextCompare) = 0 Then
'一致するか確認
'一致位置を返す
StrComp_ArraySt1 = cnt
Exit For
End If
Next
End Function
保存シートのVisual Basic Editor側 - 保存ボタンが押されたときの処理
保存ボタンが押されたとき、指定のファイルパス(セルB12)のエクセルファイルをオープンして、移動させる指定シート名(セルD14[入力規則リスト])と同一のシート名があるかどうかを確認します。同一シート名が存在する場合、置き換えるか置き換えないかのダイアログを表示させます。置き換えるを選択した場合は、オープンしたファイル側の同一シート名のシートを削除し、マクロ有効ファイル(ThisWorkbook)の指定シートを移動させます。置き換えないを選択した場合は、指定シートを移動します。（シート名は、エクセルによって(2)や(3)が付加されます）。
置き換えないを選択した場合、ユーザがシート名を変更できるように、開いたエクセルファイル(xlsx)を閉じずに処理を終了するようにしています。
シートの裏側のマクロコードは、xlsxファイルとして保存すると自動で削除されますが、保存するまでは、残されています。開いた状態を維持するルート（同一のシート名が存在する場合に、置き換えないを選択した場合）があるため、マクロの削除処理を入れています。
Private Sub SheetCopyOut_Click()
Dim FilePathRng As Range
Dim SheetnameRng As Range
Dim SheetListRng As Range
Dim copySheet, ChkSheet As Worksheet
Dim outbook As Workbook
Dim MsgResult As VbMsgBoxResult
Dim chkClose As Boolean
'シート内の固定Range情報を取得
Set FilePathRng = GetOutFilePathRng
Set SheetnameRng = GetOutSheetNameRng
Set SheetListRng = GetSheetNameListRng
'初期化（開いたファイルを閉じる）
chkClose = True
'ファイルを開く
Set outbook = OpenBook(FilePathRng.Text)
Me.Activate 'このシートをActiveに変更
If IsSameSheetName(outbook, SheetnameRng.Value) = True Then
'同一シート名が移動先ブック内に存在するか確認
MsgResult = MsgBox("同シート名があります。置き換えますか？", vbYesNo + vbQuestion)
If MsgResult = vbYes Then
'シートを置き換える
Application.DisplayAlerts = False
'コピー
Set copySheet = MoveSheet_BooktoBook(ThisWorkbook, SheetnameRng.Text, outbook)
'削除
outbook.Activate
outbook.Worksheets(SheetnameRng.Value).Delete
'リネーム
copySheet.Name = SheetnameRng.Text
Application.DisplayAlerts = True
Else
'移動
Set copySheet = MoveSheet_BooktoBook(ThisWorkbook, SheetnameRng.Text, outbook)
'ファイルを閉じない
chkClose = False
End If
Else
'移動
Set copySheet = MoveSheet_BooktoBook(ThisWorkbook, SheetnameRng.Text, outbook)
End If
Call DeleteSheetMacro(outbook, copySheet)
outbook.Save
If chkClose = True Then
outbook.Close
End If
'入力規則を削除
SheetnameRng.Validation.Delete
'出力シート名を初期化
SheetnameRng.Value = ""
'シートリスト削除
Call ClearRange(SheetListRng, "Row")
Set FilePathRng = Nothing
Set SheetnameRng = Nothing
End Sub
上記で呼び出しているOpenBook()については、別ページの「別ファイルへシートの複製」を参照してください。また、IsSameSheetName()についても、別ページの「別ファイルへシートの複製」を参照してください。
MoveSheet_BooktoBook()と、DeleteSheetMacroは、標準モジュールに記載します。
標準モジュール側- 保存ボタンクリック時の処理から呼び出される関数
エクセルのシートオブジェクトには、移動のためのMove関数がありますが、エラー発生時を考慮して、Copy関数を使用し、成功した場合にコピー元シートを削除するようにしています。
'**********************************************************************
' エクセルシートの移動処理
' (コピー元：inbookのシート名(inSheetName)、
' コピー先：outbookでコピー後シート名(outSheetName)
'
' (inbook)のシート名「in_copy_sheet_name」を
' (outbook)の先頭へ移動後、シート名を「out_copy_sheet_name」に変更し、
' (inbook)のシート名「in_copy_sheet_name」を削除
' 戻り値：なし
'**********************************************************************
Function MoveSheet_BooktoBook(ByVal inbook As Workbook, _
ByVal inSheetName As String, _
ByVal outbook As Workbook, _
Optional ByVal outSheetName As String = "") As Worksheet
Dim out_sheet As Worksheet
Dim backup_alert As Boolean
Set out_sheet = CopySheet_BooktoBook(inbook, inSheetName, outbook, outSheetName)
backup_alert = Application.DisplayAlerts
Application.DisplayAlerts = False
'シート削除
inbook.Worksheets(inSheetName).Delete
Application.DisplayAlerts = backup_alert
Set MoveSheet_BooktoBook = out_sheet
Set out_sheet = Nothing
End Function
CopySheet_BooktoBook()については、「別ファイルへシートの複製」のページを参照してください。
'**********************************
' 指定シートのマクロコードを削除
'**********************************
Function DeleteSheetMacro(ByVal TargetBook As Workbook, ByVal targetSheet As Worksheet)
Dim TargetModule As Object
With TargetBook.VBProject
'指定シートのモジュールオブジェクトをセット
Set TargetModule = .VBComponents(targetSheet.CodeName).CodeModule
End With
'モジュールオブジェクト内のコードをすべて削除
Call TargetModule.DeleteLines(1, TargetModule.CountOfLines)
End Function
ポイント
関数が増えてくると、たどるのが大変になりますが、Visual Basic Editorでは、関数名を右クリックして「定義」を選択すると作成した関数であれば、記述した個所を表示させることができます。
シートイベントをコピーするマクロ有効エクセルファイルのダウンロード
ダウンロードしたエクセルファイルを起動し、コンテンツの有効化を行う。
マクロの有効化手順については、こちらも参考にしてください。