Tips

  Application.ScreenUpdating = False

' XlMousePointer 列挙
  Application.Cursor = xlDefault        ' 標準のポインタ
  Application.Cursor = xlIBeam          ' i 字型ポインタ
  Application.Cursor = xlNorthwestArrow ' 矢印型ポインタ
  Application.Cursor = xlWait           ' 砂時計型ポインタ

  Application.EnableCancelKey = xlDisabled     ' 割り込みを無視
  Application.EnableCancelKey = xlErrorHandler ' エラーを送り、 On Error GoTo ステートメントでトラップできます。エラーコードは18
  Application.EnableCancelKey = xlInterrupt    ' デバッグ､終了などを行えるように､実行中のプロシージャを停止

' 初期処理
Sub Auto_Open()
  Application.OnKey "^m", "OnNowClick" ' ショートカットキーの登録　Ctrl + M
End Sub

' 今日の日付と今の時間の表示
Sub OnNowClick()
  MsgBox Prompt:=Now(), Buttons:=vbInformation, Title:="今日の日付と今の時間"
End Sub

' 終了処理
Sub Auto_Close()
  Application.OnKey "^m" ' ショートカットキーの取り消し
End Sub

  Application.DisplayAlerts = False ' 警告やメッセージを表示しない

  Application.EnableEvents = False ' イベントを発生させない
  
  Application.Wait Now + TimeValue("00:00:05") ' 5秒間待つ
  
  Application.EnableEvents = True ' イベントが発生します

  Debug.Print Application.WorksheetFunction.Dec2Hex(13) ' 10進数の13は16進数ではD

  Debug.Print Application.Evaluate("Code(" & """A""" & " )") ' A=65

'===========================================================
' ユーザー定義関数の登録
'===========================================================
Private Sub RegistMacro()
  Const csCategory = "私の関数"
  Dim str As String
  
  On Error Resume Next ' アドインの場合は「MacroOptions」でエラーになるため
  
  str = "指定した年から閏年か判定する"
  Application.MacroOptions Macro:="閏年", Description:=str, Category:=csCategory, StatusBar:=str
  
  str = "干支を取得する"
  Application.MacroOptions Macro:="干支", Description:=str, Category:=csCategory, StatusBar:=str
  
  On Error GoTo 0
End Sub
'===========================================================
' 指定した年から閏年か判定する
'===========================================================
Public Function 閏年(年 As Long) As Boolean
  Application.Volatile ' いずれかのセルで計算が行われるたびに再計算を行う
  閏年 = ((年 Mod 400) = 0) Or (((年 Mod 100) <> 0) And ((年 Mod 4) = 0))
End Function
'===========================================================
' 干支を取得する
'===========================================================
Public Function 干支(年)
  Application.Volatile ' いずれかのセルで計算が行われるたびに再計算を行う
  干支 = Mid("申酉戌亥子丑寅卯辰己午未", (年 Mod 12) + 1, 1)
End Function

  Application.Dialogs(xlDialogSelectSpecial).Show ' [条件を選択してジャンプ]の[選択オプション]ダイアログを表示

  Dim fn As Variant ' ファイル名の一覧
  Dim i As Long
  
  fn = Application.GetOpenFilename(FileFilter:=" エクセルのファイル(*.xl*),*.xl*, すべてのファイル (*.*),*.*", Title:="ファイルの選択", MultiSelect:=True)
  If VarType(fn) = vbBoolean Then Exit Sub ' [Cancel]ボタンを押したら終了
  For i = LBound(fn) To UBound(fn)
    Debug.Print fn(i)
  Next i
  
  Application.VBE.Windows("イミディエイト").Visible = True ' イミディエイトウィンドウを表示します。

  Application.Dialogs(xlDialogOpen).Show

  Dim FileName As String

  If ActiveWorkbook Is Nothing Then Exit Sub ' アクティブブックがなければ終了
  FileName = Format(Now(), "Long Date") & ".xls" ' YYYY年M月D日.xls
  Application.Dialogs(xlDialogSaveAs).Show FileName ' 日付のファイル名を代入して［名前を付けて保存］ダイアログを表示

Private Function GetExcelVersion() As String
  Select Case CInt(Application.Version)
    Case Is = 12
      GetExcelVersion = "2007"
    Case Is = 11
      GetExcelVersion = "2003"
    Case Is = 10
      GetExcelVersion = "2002"
    Case Is = 9
      GetExcelVersion = "2000"
    Case Is = 8
      If InStr(Application.OperatingSystem, "Windows") > 0 Then
        GetExcelVersion = "97" ' Windowsは97
      Else
        GetExcelVersion = "98" ' Macの場合は98
      End If
    Case Is = 7
      GetExcelVersion = "95"
    Case Is = 5
      GetExcelVersion = "5.0"
    Case Else
      GetExcelVersion = "不明 " & Application.Version
  End Select
End Function
'
Sub PrintExcelVersion()
  Debug.Print "Excel " & GetExcelVersion()
End Sub

  Dim wb As Workbook

  For Each wb In Workbooks
    Debug.Print wb.Name
  Next wb

Option Compare Binary ' ◆ バイナリモードで文字列を比較する（小文字と大文字、半角と全角、カタカナとひらがなを区別する）
Function ExistsWorkbook(WorkbookName As String) As Boolean
  Dim wb As Workbook
  
  ExistsWorkbook = False
  For Each wb In Workbooks
    If LCase(wb.Name) = LCase(WorkbookName) Then ' ◆ 英字の小文字と大文字は区別しない
      ExistsWorkbook = True
      Exit Function
    End If
  Next wb
End Function

Private Sub Workbook_Open()
  Application.Wait Now + TimeValue("00:00:01") ' 1秒間待つ
  If IMEStatus = vbIMEModeOff Then SendKeys "{kanji}", True ' [半角/全角]キーを押して、漢字モードにする。　＊注意　タイミングによっては実行されない場合があります
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  If Not ThisWorkbook.Saved Then ThisWorkbook.Save ' ブックを更新した場合は保存します。
End Sub

  Dim sh As Object
  
  If ActiveWorkbook Is Nothing Then Exit Sub ' アクティブブックがなければ終了
  
  For Each sh In ActiveWorkbook.Sheets
    Debug.Print sh.Name ' シート名
  Next sh

  Dim sh As Object
  
  If ActiveWorkbook Is Nothing Then Exit Sub ' アクティブブックがなければ終了
  
  For Each sh In ActiveWorkbook.Worksheets
    Debug.Print sh.Name ' ワークシート名
  Next sh

Option Compare Binary ' ◆ バイナリモードで文字列を比較する（小文字と大文字、半角と全角、カタカナとひらがなを区別する）

Function ExistsSheet(sName As String) As Boolean
  Dim sh As Object
  
  ExistsSheet = False
  If ActiveWorkbook Is Nothing Then Exit Function
  For Each sh In ActiveWorkbook.Sheets ' ● すべてのシート
    If StrConv(LCase(sh.Name), vbWide) = StrConv(LCase(sName), vbWide) Then ' ◆ 英字の小文字と大文字は区別しない、かつ半角と全角は区別しない
      ExistsSheet = True
      Exit Function
    End If
  Next sh
End Function

Function ExistsWorkSheet(WorkSheetName As String) As Boolean
  Dim sh As Object
  
  ExistsWorkSheet = False
  If ActiveWorkbook Is Nothing Then Exit Function
  For Each sh In ActiveWorkbook.Worksheets ' ●注意　シートでなく、ワークシートのみ（グラフとダイアログは除く）
    If StrConv(LCase(sh.Name), vbWide) = StrConv(LCase(WorkSheetName), vbWide) Then ' ◆ 英字の小文字と大文字は区別しない、かつ半角と全角は区別しない
      ExistsWorkSheet = True
      Exit Function
    End If
  Next sh
End Function

Function VisibleSheetCount() As Long
  Dim sh As Object
  
  VisibleSheetCount = 0
  If Workbooks.Count < 1 Then Exit Function
  For Each sh In Sheets
    If sh.Visible = xlSheetVisible Then VisibleSheetCount = VisibleSheetCount + 1
  Next sh
End Function

Function VisibleWorksheetCount() As Long
  Dim sh As Worksheet
  
  VisibleWorksheetCount = 0
  If Workbooks.Count < 1 Then Exit Function
  For Each sh In Worksheets
    If sh.Visible = xlSheetVisible Then VisibleWorksheetCount = VisibleWorksheetCount + 1
  Next sh
End Function

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  Cells.Select

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  ActiveCell.CurrentRegion.Select

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  On Error Resume Next ' エラーを無視して次の行を実行
  ActiveCell.SpecialCells(xlCellTypeAllFormatConditions).Select  ' 表示形式が設定されているセルを選択する
  ActiveCell.SpecialCells(xlCellTypeAllValidation).Select        ' 条件の設定が含まれているセルを選択する
  ActiveCell.SpecialCells(xlCellTypeBlanks).Select               ' 空の文字列のセルを選択する
  ActiveCell.SpecialCells(xlCellTypeComments).Select             ' コメントが含まれているセルを選択する
  ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Activate    ' 使われたセル範囲の最後のセルを選択する
  ActiveCell.SpecialCells(xlCellTypeSameFormatConditions).Select ' 同じ表示形式が設定されているセルを選択する
  ActiveCell.SpecialCells(xlCellTypeSameValidation).Select       ' 同じ条件の設定が含まれているセルを選択する
  ActiveCell.SpecialCells(xlCellTypeVisible).Select              ' すべての可視セルを選択する
'
  ActiveCell.SpecialCells(xlCellTypeConstants).Select            ' 定数が含まれているセルを選択する
  ActiveCell.SpecialCells(xlCellTypeConstants, xlNumbers).Select ' 定数（数値）が含まれているセルを選択する
  
  ActiveCell.SpecialCells(xlCellTypeFormulas).Select             ' 数式が含まれているセルを選択する
  ActiveCell.SpecialCells(xlCellTypeFormulas, xlErrors).Select   ' 数式（エラー値）が含まれているセルを選択する
  On Error GoTo 0

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  ActiveSheet.UsedRange.Select

'===========================================================
' 指定した列の入力されている再終行に移動する
'===========================================================
Sub GotoLastInputRow(Optional ColumnNumber As Long = 1) ' ColumnNumber:列の番号（A列は1、B列は2...）
  
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If ColumnNumber < 1 Then Exit Sub
  
  With Application.Cells(Rows.Count, ColumnNumber)
    If .Value = "" Then
      .End(xlUp).Select ' ショートカットキーの Ctrl + ↑ と同じ
    Else
      .Select
    End If
  End With
End Sub
'===========================================================
' B列の入力されている再終行に移動する
'===========================================================
Sub TestGotoLastInputRow()
  GotoLastInputRow 2  ' B列の入力されている再終行に移動する
End Sub

  Dim r1, r2 As Range  ' セルの選択範囲
  Dim IntersectRange As Range  ' 共有セル範囲
  Dim Msg As String ' メッセージ
  
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  
  Set r1 = Application.InputBox(Prompt:="複数のセルを選択してください", Title:="セルの選択", Type:=8)
  If TypeName(r1) <> "Range" Then Exit Sub ' [Cancel]ボタンを押した。
  r1.Interior.ColorIndex = 5 ' 青

  Set r2 = Application.InputBox(Prompt:="複数のセルを選択してください", Title:="セルの選択", Type:=8)
  If TypeName(r2) <> "Range" Then Exit Sub ' [Cancel]ボタンを押した。
  r2.Interior.ColorIndex = 6 ' 黄色
  
  Set IntersectRange = Application.Intersect(r1, r2)
  Msg = "セル範囲の集合：" & Application.Union(r1, r2).Address(RowAbsolute:=False, ColumnAbsolute:=False) & vbCrLf
  If Not IntersectRange Is Nothing Then
    Msg = Msg & "共有セル範囲：" & IntersectRange.Address(RowAbsolute:=False, ColumnAbsolute:=False)
    IntersectRange.Interior.ColorIndex = 4 ' 黄緑
    IntersectRange.Select
  End If
      
  MsgBox Prompt:=Msg, Buttons:=vbOKOnly + vbInformation

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  
  With ActiveCell.CurrentRegion ' アクティブセル領域（空白行と空白列で囲まれたセル範囲）
    If .Rows.Count < 2 Then Exit Sub ' 1行以下は何もしないで終了
    .Offset(RowOffset:=1).Resize(Rowsize:=.Rows.Count - 1).Select ' 2行目以降のセルを選択する
  End With

  Dim SaveActiveSheet As Worksheet ' アクティブシートを保存
  Dim TempWorksheet As Worksheet ' 一時シート
  
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If StrComp(TypeName(Selection), "Range") <> 0 Then Exit Sub ' セルを選択していなければ終了
  If (Selection.Areas.Count <> 1) Or (Selection.Count = 1) Then
    MsgBox "セル範囲が正しくありません!", vbOKCancel + vbExclamation
    Exit Sub
  End If
  
  If (Selection.Columns.Count <> 2) And (Selection.Rows.Count <> 2) Then
    MsgBox "２列あるいは２行のセル範囲を選択してください!", vbOKCancel + vbExclamation
    Exit Sub
  End If
  
  Set SaveActiveSheet = ActiveSheet ' アクティブシートの保存
  Set TempWorksheet = Worksheets.Add 'ワークシートの追加
  SaveActiveSheet.Activate ' 元のアクティブシートを選択
  Selection.Copy Destination:=TempWorksheet.Range("A1") ' 選択セル範囲の保存
  If Selection.Columns.Count = 2 Then ' ２列の場合
    Selection.Columns(2).Copy Destination:=Selection.Columns(1) ' ２列目を１列目にコピー
    TempWorksheet.Range("A1").CurrentRegion.Columns(1).Copy Destination:=Selection.Columns(2) ' 保存した１列目を２列目にコピー
  Else ' ２行の場合
    Selection.Rows(2).Copy Destination:=Selection.Rows(1) ' ２行目を１行目にコピー
    TempWorksheet.Range("A1").CurrentRegion.Rows(1).Copy Destination:=Selection.Rows(2) ' 保存した１行目を２行目にコピー
  End If
  
  Application.DisplayAlerts = False ' 警告やメッセージを表示しない
  TempWorksheet.Delete ' 一時シートの削除
  Application.DisplayAlerts = True ' 警告やメッセージを表示する

  Dim i As Long
  
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If StrComp(TypeName(Selection), "Range") <> 0 Then Exit Sub ' セルを選択していなければ終了
  Debug.Print "Areas.Count:" & Selection.Areas.Count
  For i = 1 To Selection.Areas.Count
    Debug.Print
    With Selection.Areas(i)
      Debug.Print "Areas(" & CStr(i) & ").Count:" & .Count
      Debug.Print "Areas(" & CStr(i) & ").Address=" & .Address(RowAbsolute:=False, ColumnAbsolute:=False)
      Debug.Print "Left  Top    Address:" & .Cells(1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
      Debug.Print "Right Top    Address:" & .Cells(1, .Columns.Count).Address(RowAbsolute:=False, ColumnAbsolute:=False)
      Debug.Print "Left  Bottom Address:" & .Cells(.Rows.Count, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
      Debug.Print "Right Bottom Address:" & .Cells(.Count).Address(RowAbsolute:=False, ColumnAbsolute:=False)
    End With
  Next i
  
  Application.VBE.Windows("イミディエイト").Visible = True ' イミディエイトウィンドウを表示します。

  Dim SaveActiveSheet As Worksheet ' アクティブシートを保存
  Dim TempWorksheet As Worksheet ' 一時シート
  
  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If StrComp(TypeName(Selection), "Range") <> 0 Then Exit Sub ' セルを選択していなければ終了
  If Selection.Areas.Count <> 2 Then
    MsgBox "２つの隣接しないセル範囲を選択してください!", vbOKCancel + vbExclamation
    Exit Sub
  End If
  If (Selection.Areas(1).Columns.Count <> Selection.Areas(2).Columns.Count) Or (Selection.Areas(1).Rows.Count <> Selection.Areas(2).Rows.Count) Then
    MsgBox "同じサイズのセル範囲を選択してください!", vbOKCancel + vbExclamation
    Exit Sub
  End If
  
  Set SaveActiveSheet = ActiveSheet ' アクティブシートの保存
  Set TempWorksheet = Worksheets.Add 'ワークシートの追加
  SaveActiveSheet.Activate ' 元のアクティブシートを選択
    
  Selection.Areas(1).Copy Destination:=TempWorksheet.Range("A1")
  Selection.Areas(2).Copy Destination:=Selection.Areas(1)
  TempWorksheet.Range("A1").CurrentRegion.Copy Destination:=Selection.Areas(2)
  
  Application.DisplayAlerts = False ' 警告やメッセージを表示しない
  TempWorksheet.Delete ' 一時シートの削除
  Application.DisplayAlerts = True ' 警告やメッセージを表示する

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If StrComp(TypeName(Selection), "Range") <> 0 Then Exit Sub ' セルを選択していなければ終了
  Selection.EntireColumn.Select

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If StrComp(TypeName(Selection), "Range") <> 0 Then Exit Sub ' セルを選択していなければ終了
  Selection.EntireRow.Select

  Debug.Print Application.StartupPath ' Excelの起動フォルダの絶対パス（末尾の円記号 (\) は含まない）
  Debug.Print Application.DefaultFilePath ' ファイルを開くときに既定のカレントフォルダ名
  Debug.Print Application.TemplatesPath 'テンプレートが保存されているローカルパス
  Debug.Print Application.UserLibraryPath ' COM アドインがインストールされているパス

Option Explicit

  SendKeys "^o", Wait:=True ' Ctrl + O ファイルを開く

  Debug.Print "小文字 " & StrConv("abcDEF", vbLowerCase)
  Debug.Print "大文字 " & StrConv("abcDEF", vbUpperCase)
  Debug.Print "先頭のみ大文字 " & StrConv("abcDEF", vbProperCase)
  Debug.Print "半角 " & StrConv("ｱｲｳエお", vbNarrow)
  Debug.Print "全角 " & StrConv("ｱｲｳエお", vbWide)
  Debug.Print "カタカナ " & StrConv("ｱｲｳエお", vbKatakana)
  Debug.Print "ひらがな " & StrConv("ｱｲｳエお", vbHiragana)
  Debug.Print "バイト数（Unicode）： " & LenB(StrConv("ｱｲｳエお", vbUnicode)) ' ユニコードでは半角の文字でも、1文字は２バイトになります
  Debug.Print "バイト数（Shift JIS）： " & LenB(StrConv("ｱｲｳエお", vbFromUnicode))

' ブックのドキュメントプロパティの取得し、新規作成したシートに書き込む。
  Dim RowCnt As Long ' セルの行番号
  Dim dp As DocumentProperty ' ドキュメント プロパティ
  
  If ActiveWorkbook Is Nothing Then Exit Sub ' アクティブブックがなければ終了
  On Error Resume Next
  RowCnt = 1
  With Worksheets.Add
    .Name = "BuiltinDocumentProperties"
    For Each dp In ActiveWorkbook.BuiltinDocumentProperties
      Cells(RowCnt, 1).Value = dp.Name
      Cells(RowCnt, 2).Value = dp.Value
      RowCnt = RowCnt + 1
    Next dp
    Columns("A:B").AutoFit ' セルの列幅を内容に合わせて調整する
    Range("A1").Activate
  End With
  On Error GoTo 0

  Dim ProgID
  
  ProgID = Shell("Notepad.exe", vbNormalFocus) ' メモ帳を起動
  If ProgID = 0 Then Exit Sub ' 問題発生したので終了
  Application.Wait Now + TimeValue("00:00:01") ' １秒間待つ
  AppActivate ProgID ' メモ帳をアクティブにする
  SendKeys ".LOG{ENTER}" '
  ' 先頭行が「.LOG」のファイルを次回からメモ帳で開くと、日付と時間が自動で挿入されます。

  Dim PathName As String ' 検索するパス名（C:\Users\≪ユーザ名≫\Documents\*.xl*　≪ユーザ名≫はログオンしたユーザ名により異なる）
  Dim FileName As String ' 取得するファイル名
  
  PathName = Application.DefaultFilePath & Application.PathSeparator & "*.xl*"
  FileName = Dir(PathName, vbArchive + vbReadOnly + vbSystem + vbHidden)
  Do While FileName <> ""
    Debug.Print FileName
    FileName = Dir()
  Loop

  
  On Error Resume Next ' エラーでも中断せず、次のステートメントから実行
  Worksheets.Add.Name = "Sample" ' 既に同じシート名が存在していても、エラーにはならない。
  On Error GoTo 0 ' エラーの場合は実行時エラーを発生する

  Dim Ret As VbMsgBoxResult ' MsgBoxの返値
  Dim Msg As String ' メッセージ
  Dim Num As Variant ' 入力の値
  Dim A, B As Double ' 入力の数字
  Dim Ans As Double ' 答え
  
  On Error GoTo Error_Handle ' エラーが発生したら、「Error_Handle」ラベルに移動する
  Num = Application.InputBox(prompt:="A / BのAの数字を入力してください。", Title:="数字の入力", Type:=1)
  If VarType(Num) = vbBoolean Then Exit Sub ' [キャンセル]ボタンを押したので終了
  A = Num
  
  Num = Application.InputBox(prompt:="A / BのBの数字を入力してください。", Title:="数字の入力", Type:=1)
  If VarType(Num) = vbBoolean Then Exit Sub ' [キャンセル]ボタンを押したので終了
  B = Num
  
  Ans = A / B ' ● Bの値が0の場合にエラーが発生する
  MsgBox prompt:=A & " / " & B & " = " & Ans, Title:="答え"
  Exit Sub
  
Error_Handle: ' エラー処理
  Msg = "エラー番号：" & Err.Number & vbCrLf & Err.Description
  Err.Clear ' エラーをクリアー
  Ret = MsgBox(Msg, vbExclamation + vbAbortRetryIgnore)
  Select Case Ret
    Case vbAbort ' 中止
      Exit Sub
    Case vbRetry ' 再試行
      Resume ' 同じ行のステートメントを実行 ＊注意 この例では再度エラーになる、Bの値を再入力する必要があります。
    Case vbIgnore '無視
      Resume Next ' 次の行のステートメントから実行
  End Select

' 月末日()・・・今月の月末日を取得する
' 月末日(年月日 as Date)・・・指定した年月日の月末日を取得する
' 月末日(年,月 as Integer)・・・指定した年と月の月末日を取得する
Function 月末日(Optional Arg1, Optional Arg2) As Date
  Dim Today As Date ' 今日
  
  If IsMissing(Arg1) Then ' 月末日()
    Today = Now()
    月末日 = DateSerial(year(Today), Month(Today) + 1, 1) - 1
  ElseIf IsMissing(Arg2) Then ' 月末日(年月日)
    月末日 = DateSerial(year(Arg1), Month(Arg1) + 1, 1) - 1
  Else ' 月末日(年,月)
    月末日 = DateSerial(Arg1, Arg2 + 1, 1) - 1
  End If
End Function
'-----------------------------------------------------------
Sub test月末日()
  Dim Today As Date ' 今日
  Dim InputDate As Variant ' 入力した日付
  
  Today = Now()
  Debug.Print "先月の月末日は" & 月末日(year(Today), Month(Today) - 1)
  Debug.Print "今月の月末日は" & 月末日()
  Debug.Print "来月の月末日は" & 月末日(year(Today), Month(Today) + 1)
  
  InputDate = Application.InputBox(Prompt:="日付の入力（yyy/mm/dd）：", Title:="月末日の取得", Default:=Format(Today, "yyyy/mm/dd"), Type:=2)
  If VarType(InputDate) = vbBoolean Then Exit Sub ' [キャンセル]ボタンを押したら、終了。
  If Not IsDate(InputDate) Then Exit Sub ' 日付でなければ終了。
  Debug.Print Format(InputDate, "yyyy/mm/dd") & "の月末日は" & 月末日(year(DateValue(InputDate)), Month(DateValue(InputDate)))
End Sub

  If Application.ActiveCell Is Nothing Then Exit Sub ' ブックを開いていてワークシートを選択していない場合は終了
  If MsgBox(prompt:="すべてのオブジェクトを削除しますか？", Buttons:=vbYesNo + vbQuestion) = vbNo Then Exit Sub ' 削除の確認
  ActiveSheet.Shapes.SelectAll ' すべてのオブジェクトを選択
  Selection.Delete ' 選択したオブジェクトを削除

'=============================================================================
' メニューの処理
'=============================================================================
Const csVersion As String = "Version 1.0.0"
Const MainMenu As String = "Test Menu(&T)" ' メニューのキャプション
Const DisplayStatusBarMenu As String = "ステータスバーの表示・非表示(&S)"
Const ColumnWidthAutofitMenu As String = "選択したすべてのセルの列の幅を内容に合わせる変更(&C)"
Const RowHeightAutofitMenu As String = "選択したすべてのセルの行の高さを内容に合わせる変更(&R)"
'===========================================================
' 今日の日付と今の時間の表示
'===========================================================
Sub OnNowClick()
  MsgBox Prompt:=Now(), Buttons:=vbInformation, Title:="今日の日付と今の時間"
End Sub
'===========================================================
' 選択したすべてのセルの列の幅を内容に合わせて変更
'===========================================================
' ＊注　選択したのは列でなく、セルです。
Sub OnColumnWidthAutofitClick()
  ActiveWindow.RangeSelection.EntireColumn.AutoFit
End Sub
'===========================================================
' 選択したすべてのセルの行の高さを内容に合わせて変更
'===========================================================
' ＊注　選択したのは行でなく、セルです。
Sub OnRowHeightAutofitClick()
  ActiveWindow.RangeSelection.EntireRow.AutoFit
End Sub
'===========================================================
' ステータスバーの表示・非表示
'===========================================================
Sub OnDisplayStatusBarClick()
  Application.DisplayStatusBar = Not Application.DisplayStatusBar
End Sub
'===========================================================
' バージョン情報
'===========================================================
Sub OnAboutClick()
  Dim Msg As String
  
  Msg = ThisWorkbook.Name & vbCrLf & vbCrLf & csVersion
  MsgBox Prompt:=Msg, Buttons:=vbInformation, Title:="バージョン情報"
End Sub
'===========================================================
' Test Menuメニューのクリック
'===========================================================
Sub OnMainMenuClick()
  With Application.CommandBars("Worksheet Menu Bar").Controls(MainMenu)
    ' メニューのチェック
    .Controls(DisplayStatusBarMenu).State = Application.DisplayStatusBar
    
    ' メニューの使用可・不可 --- セルがないダイアログシートを選択した場合は使用禁止にする。
    .Controls(ColumnWidthAutofitMenu).Enabled = Not (Application.ActiveCell Is Nothing)
  End With
End Sub
'=============================================================================
' メニューの削除
'=============================================================================
Sub DelMenu()
  On Error Resume Next ' メニューがないのに削除するとエラーになるため、エラー無視
  Application.CommandBars("Worksheet Menu Bar").Controls(MainMenu).Delete
  Application.CommandBars("Cell").Controls(MainMenu).Delete
  On Error GoTo 0
End Sub
'=============================================================================
' メニューの追加
'=============================================================================
Sub SetMenu(pMenu As String)
  With Application.CommandBars(pMenu).Controls.Add(Type:=msoControlPopup, Temporary:=True) ' Temporary:=True で終了時に削除
    .Caption = MainMenu
  
    With .Controls.Add
      .Caption = ColumnWidthAutofitMenu
      .OnAction = "OnColumnWidthAutofitClick"
    End With
    With .Controls.Add
      .Caption = RowHeightAutofitMenu
      .OnAction = "OnRowHeightAutofitClick"
    End With
    
    If StrComp(pMenu, "Worksheet Menu Bar") = 0 Then ' ワークシートのメニューのみに追加
      .OnAction = "OnMainMenuClick"
      With .Controls.Add
        .Caption = "今日の日付と今の時間(&N)..."
        .OnAction = "OnNowClick"
        .BeginGroup = True
        .ShortcutText = "Ctrl+M"
      End With
      With .Controls.Add
        .Caption = DisplayStatusBarMenu
        .OnAction = "OnDisplayStatusBarClick"
        .BeginGroup = True
      End With
      With .Controls.Add
        .Caption = "バージョン情報(&A)..."
        .OnAction = "OnAboutClick"
      End With
    End If
  End With
End Sub
'-----------------------------------------------------------
Sub AddMenu()
  DelMenu ' メニューの削除
  SetMenu ("Worksheet Menu Bar") ' ワークシートのメニュー
  SetMenu ("Cell") ' セルのショートカットメニュー
End Sub
'===========================================================
' 初期処理
'===========================================================
Sub Auto_Open()
  Application.OnKey "^m", "OnNowClick" ' ショートカットキーの登録　[Ctrl]+[M]
  AddMenu ' メニューの追加
End Sub
'===========================================================
' 終了処理
'===========================================================
Sub Auto_Close()
  Application.OnKey "^m" ' ショートカットキーの取り消し
  DelMenu ' メニューの削除
End Sub
'===========================================================
' メニューのリセット
'===========================================================
Sub ResetMenu()
  Application.CommandBars("Worksheet Menu Bar").Reset ' ワークシートのメニュー
  Application.CommandBars("Cell").Reset ' セルのショートカットメニュー
End Sub

Sub ResetCommandBars()
  Dim cbar As CommandBar

  On Error Resume Next
  For Each cbar In CommandBars
    If CommandBars(cbar.Name).BuiltIn Then
      CommandBars(cbar.Name).Reset
    Else
      CommandBars(cbar.Name).Delete
    End If
  Next
  On Error GoTo 0
End Sub