Teams等で不在にしないための魔法(逆・居留守ツール)
2つマクロコードをVBE画面に貼り付け後、すぐに使用できます。
テスト後、自己責任にてご利用ください.(Microsoft365 64bit環境推奨)
- 【Alt】+【F11】キーを押下し、VBE画面を出します。
- 【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成します。
- 下記ボックス内をコピーし、標準モジュールに貼り付けます。
- モジュール名を【M01_Main】に変更します。
- 名前を付けて保存で、ファイル名:【お役立ちツール】
- ファイル形式:【Excelマクロ有効ブック :拡張子(.xlsm)】で保存します。
- 下記【M01_Main】の 22行目【Sub setSht】プロシージャ内でポイントし(1度クリックして)、キーボードの【F5】キーを押下します。
すると、【Main】シートが作成されます。
使用方法
【Main】シートが作成できたでしょうか。
セル C7で設定時間を選択し、【実行】ボタンを押下で利用できます。
※ 使用中は他のExcelは閉じて短い時間でお試し後、ご利用ください。
モジュール名:M01_Main
Option Explicit '*************************************************************** ' 【使用方法】 ' ファイルのフォントテーマを"Meiryo UI"に変更してください。 ' 2つのモジュールをコピー後、 ' ① 下記【setSht】のコード内で1度クリックし、 ' 【F5】キーを押下 ' ⇒【Main】シートが作成される ' ' ② 【Main】シートの セルC7 で時間を指定後、 ' 【実行】ボタンを押下 ' ※ 念のため、他のExcel等は閉じ、短い時間を指定して ' テスト実行後、本番使用してください。 ' 【esc】キーの長押しで、中断できます。 ' ↑メッセージボックスが出現するまで最大10秒間長押しする '*************************************************************** '==================================================== ' 【Main】シートを設定する '==================================================== Sub setSht() 'ここをポイントし、【F5】キーを押下 Dim MaxRow As Long '最終行 Dim MaxCol As Long '最終列 Dim myShp As Shape Dim nmlTmn As Boolean Dim myC As Range Dim wbName As String Dim MainSht As Worksheet Dim IsBlank As Boolean Const shtName As String = "Main" Bln_Err = False ErrProsName = "setShtErr" On Error GoTo setSht_Err Call showStatus("シート設定中") wbName = ActiveWorkbook.Name '****************************************************************************** '日本語 フォントテーマをMeiryo UIで設定 With ActiveWorkbook.Theme.ThemeFontScheme .MajorFont.Item(3).Name = "Meiryo UI" '見出しのフォント .MinorFont.Item(3).Name = "Meiryo UI" '本文のフォント End With '****************************************************************************** IsBlank = False If IsShtOwb(shtName, wbName) = False Then With Worksheets(1) With .UsedRange MaxRow = .Rows(.Rows.Count).Row MaxCol = .Columns(.Columns.Count).Column End With End With If MaxRow = 1 And MaxCol = 1 Then IsBlank = True End If If IsBlank Then Worksheets(1).Name = shtName Else ActiveWorkbook.Worksheets.Add Before:=Worksheets(1) ActiveSheet.Name = shtName End If Else With ActiveWorkbook.Worksheets(shtName) .Select .Cells.Clear End With Call delShapes End If '===================================================== Call StopUpdating Call SetObject '===================================================== 'シート設定処理 With wsMain .Range("1:12").RowHeight = 5 .Rows(2).RowHeight = 40 .Rows(5).RowHeight = 20 .Rows(7).RowHeight = 32 .Rows(9).RowHeight = 20 .Rows(10).RowHeight = 32 .Columns("A:I").ColumnWidth = 0.5 .Columns("C").ColumnWidth = 16.4 .Columns("E").ColumnWidth = 16.4 .Columns("G").ColumnWidth = 16.4 .Cells.Font.Name = "MeiryoUI" .Cells(2, 2) = "お役立ちツール I’m here." .Cells(2, 2).Font.Size = 16 .Cells(2, 2).Font.Color = RGB(255, 255, 255) .Cells(5, 3) = "設定時間" .Cells(9, 3) = "Start" .Cells(5, 5) = "中断したいときは【Esc】キーを5秒くらい長押し" .Cells(9, 5) = "End" .Range("B2:H2").Merge .Range("B2:H2").Interior.Color = RGB(0, 112, 192) .Range("B2").HorizontalAlignment = xlCenter With .Range("B4:H12") .Interior.Color = RGB(238, 242, 247) .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With .Range("E5").HorizontalAlignment = xlLeft .Range("C7").Interior.Color = xlNone '背景色無色 .Range("E7").Interior.Color = xlNone '背景色無色 .Range("C10").Interior.Color = xlNone '背景色無色 .Range("E10").Interior.Color = xlNone '背景色無色 .Range("G10").Interior.Color = xlNone '背景色無色 .Range("C5:E5").Font.Color = RGB(0, 112, 192) .Range("C9:E9").Font.Color = RGB(0, 112, 192) With .Range("C7") .NumberFormatLocal = "#"" 分""" With .Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="1,3,5,10,15,30,45,60,90" End With End With Set myC = .Range("G7") Set myShp = .Shapes.AddShape _ (msoShapeRoundedRectangle, myC.Left, myC.Top, myC.Width, myC.Height) Set myC = Nothing With myShp With .Fill .ForeColor.RGB = RGB(0, 112, 192) End With With .Line .Weight = 0.5 .ForeColor.RGB = RGB(0, 112, 192) End With With .TextFrame.Characters .Text = "実 行" .Font.Size = 12 .Font.Color = RGB(255, 255, 255) End With With .TextFrame .HorizontalAlignment = xlHAlignCenter .VerticalAlignment = xlVAlignCenter End With With .ThreeD .BevelTopType = msoBevelArtDeco .BevelTopInset = 9 .BevelTopDepth = 6 End With .OnAction = "exeBeHere" End With End With nmlTmn = True setSht_Exit: 'エラーを無視 On Error Resume Next Call ReSetObject Call Updating If nmlTmn Then MsgBox " 完了♪" End If 'エラー制御を戻す On Error GoTo 0 Exit Sub setSht_Err: Bln_Err = True MsgBox "実行時エラー:" & Err.Nuer & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName Err.Clear 'エラー情報クリア GoTo setSht_Exit End Sub '==================================================== ' I'm here. TOOL '==================================================== Sub exeBeHere() Dim cnt As Long Dim tgtM As Long Dim x As Long Dim MaxNo As Long Dim SttTime As Date Dim EndTime As Date Dim ErrProsName As String Dim nmlTmn As Boolean '正常終了フラグ:normal Termination Bln_Err = False nmlTmn = False ErrProsName = "exeBeHere" On Error GoTo exeBeHere_Err '[Esc]キーでエラーをトラップする Application.EnableCancelKey = xlErrorHandler nmlTmn = False Call showStatus("I'm Here") Call SetObject '===================================================== With wsMain tgtM = .Cells(7, 3) SttTime = Now() .Cells(7, 5) = "" .Cells(10, 3) = Format(SttTime, "hh:mm:ss") .Cells(9, 5) = "Now" .Cells(10, 5) = "" .Cells(10, 7) = "" .Cells(7, 5).Select If tgtM = 0 Then MsgBox "設定時間を選択してください。" & vbCr & _ "処理を終了します。", vbExclamation Err.Clear 'エラー情報クリア GoTo exeBeHere_Exit End If MaxNo = tgtM * 3 Select Case tgtM Case 1 EndTime = SttTime + TimeValue("0:01:00") Case 3 EndTime = SttTime + TimeValue("0:03:00") Case 5 EndTime = SttTime + TimeValue("0:05:00") Case 10 EndTime = SttTime + TimeValue("0:10:00") Case 15 EndTime = SttTime + TimeValue("0:15:00") Case 30 EndTime = SttTime + TimeValue("0:30:00") Case 45 EndTime = SttTime + TimeValue("0:45:00") Case 60 EndTime = SttTime + TimeValue("1:00:00") Case 90 EndTime = SttTime + TimeValue("1:30:00") End Select '[Esc]キーでエラーをトラップする Application.EnableCancelKey = xlErrorHandler GoTo There .Cells(7, 5).Select MaxNo = 10 Do While Now < EndTime On Error GoTo There If .Cells(7, 5) = "" Then '機能を見える化的演出 If x Mod 2 = 0 Then SendKeys "{down}" Else SendKeys "{Up}" End If x = x + 1 Application.Wait (Now + TimeValue("0:00:05")) .Cells(10, 5) = Format(Now, "hh:mm:ss") .Cells(10, 7) = x DoEvents Else GoTo exeBeHere_Err End If There: If Err.Number > 0 Then Select Case Err.Number '【esc】キーが押された場合 Case 18 If MsgBox("終了しますか?", vbQuestion + vbYesNo) = vbNo Then Resume Else .Cells(7, 5) = "中断" GoTo exeBeHere_Exit End If Err.Clear On Error GoTo 0 'その他のエラーの場合 Case Else Debug.Print Err.Number Debug.Print Err.Description Err.Clear On Error GoTo 0 End Select End If Loop End With nmlTmn = True exeBeHere_Exit: 'エラーを無視 On Error Resume Next With wsMain .Cells(9, 5) = "End" .Cells(10, 5) = Format(Time, "hh:mm:ss") End With Call ReSetObject Call Updating Call ClearStatus If nmlTmn Then MsgBox " 終了♪" End If 'エラー制御を戻す On Error GoTo 0 Exit Sub exeBeHere_Err: Bln_Err = True If Err.Number = 18 Then If MsgBox("マクロを終了しますか?", vbYesNo) = vbYes Then GoTo exeBeHere_Exit Else Resume End If Else 'その他のエラー MsgBox "実行時エラー:" & Err.Number & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName Err.Clear 'エラー情報クリア GoTo exeBeHere_Exit End If End Sub
コメント