病棟に置いてある救急カートの薬品期限チェックは、毎月月末にひとつずつ目視で確認、交換していたのですが、こういった作業はできるだけ短縮して時間を節約したいものです。特に定数配置している薬品が複数部署にまたがると、確認作業に時間がかかってしまいがちです。
そこで今回はExcelVBAを使って、月末で使用期限が切れる薬品が一目でわかるようなプログラムを作ることにしました。
今回作成するプログラム
概要
各部署に定数配置している薬品リストのExcelファイルがあり、シート中のチェックボタンをクリックすると、当月に使用期限を迎える薬品のセルの色が変わるプログラムです。
品目や部署がたくさんあっても、月末に交換しなくてはならない薬品がどの部署で何個あるか、が一目でわかるようなものにしたいと思います。
Excelファイルの構成と使用のイメージを下に示します。（画像中の品名や部署名は適当です）
ファイルを開いて、「期限チェック」のボタンを押すと例えば今月（もしくは、指定した月）が2025年5月だったら、「2025/5」が含まれるセルの色が黄色に塗りつぶされます。
交換作業が済んだら新たに該当セルに新たな使用期限の入力を行うようにします。*1
セルの記入ルール
| 入力形式 | 半角で入力する |
| 年月の書き方 | yyyy/mm （月が1桁の場合はyyyy/m） |
| 数量の記載 | 年月の後にアスタリスク（*）と数量を書く（例：2025/5*2） |
| 複数期限の記載 | カンマ （,） で区切って1セルにまとめて入力（例：2025/5*1,2026/4*2） |
| その他 | セル内で「Alt + Enter」で改行しても可。空白（スペース）はあっても良い |
コードについて
このプログラムでは、表中の赤枠で囲まれたセル範囲を順にチェックし、指定された年月が含まれるセルを塗りつぶす処理を行います。
ここでは主要な関数（サブルーチン）を簡単にいくつか解説します。
全体のコードは記事末に掲載していますので、併せてご覧ください。
- runExpiryCheck
シート上の「期限チェック」ボタンをクリックしたときに最初に呼び出される関数です。
・シートの塗りつぶしを初期化（クリアする）
・年月を入力するフォーム（InputBox）を表示
・チェック対象セルを走査し、該当があれば塗りつぶしを実行するcolorMatchingCells関数を呼び出す
＜入力フォームのイメージ＞
- containsMatchingExpiry
この関数は、セルに記載された期限の文字列（例：2025/5*2, 2026/4*1）に、
ユーザーが指定した年月（CHECK_DATE）が含まれているかどうかを判定します。
具体的な処理の流れとしては以下の通りです：
・セル内の文字列をカンマで分割
・各項目からスペースや改行コードを削除
・「年月」部分だけを取り出し
・取り出した年月がCHECK_DATE と一致するかを判定
コードの各関数にはコメントも付けていますので、必要に応じてそちらも参考にしてみてください。
エクセルマクロを実行するには
マクロは、エクセル上の「ボタンをクリック」して実行できるようにすると便利です。
- Excelのシート上で、メニューの [挿入] → [図形] から、お好みの図形（角丸四角形など）を選び、シート上に配置します。*2
- ボタンの中に「期限チェック」などのテキストを入力します。
- 図形を右クリック → [マクロの登録] を選んで、一覧から今回のコードの実行を開始する場所である runExpiryCheck を選択すれば完了です。
補足：VBAマクロを動かすための準備
全くの初心者の方は「VBAでコードを書く」と聞くと難しく感じるかもしれませんが、以下の手順で簡単に始められます。
- Alt + F11キーでVBE（Visual Basic Editor）を起動→ Excelのマクロの編集画面が開きます。さらにメニューから [挿入] → [標準モジュール] を選びます。Module1 などの名前がついた領域が表示されるので、ここにコードを貼り付けます。
- セキュリティ設定を確認→ マクロの実行時に警告が出ることがあります。[ファイル] → [オプション] → [セキュリティセンター] → [マクロの設定] で「すべてのマクロを有効にする」か「警告を表示してマクロを有効にする」に設定します。（自己責任で調整を）
- ファイルの保存は「.xlsm」で行う→ マクロを含むブックは「.xlsm（マクロ有効ブック）」で保存する必要があります。
参考
コード全体です
Option Explicit ' 定数(Const)は実際に使用する環境に合わせて適宜変更する Public Const BASE_ADDRESS As String = "E3" ' チェック対象表の左上セル Public Const TABLE_LAST_COL As String = "G" ' チェック対象表の右端列のアルファベット Public Const SHEET_NAME As String = "定数配置一覧" ' シート名 Private CHECK_DATE As String ' 期限チェック実行 Sub runExpiryCheck() Call clearHighlighting CHECK_DATE = Application.InputBox( _ Prompt:="チェックする年月を入力してください（例：2025/5）", _ Title:="対象年月を入力", _ Default:=Format(Date, "yyyy/m")) ' デフォルトは現在の年月（yyyy/m形式） If CHECK_DATE = "False" Then Exit Sub ' キャンセル対応 Call colorMatchingCells(getTableArea()) End Sub ' 塗りつぶしクリア Sub clearHighlighting() getTableArea().Interior.ColorIndex = xlNone End Sub ' チェックする表の範囲を設定 Function getTableArea() As range Dim tableArea As range Dim base_cell As range Dim last_row As Long Set base_cell = Worksheets(SHEET_NAME).range(BASE_ADDRESS) Set tableArea = base_cell.CurrentRegion last_row = tableArea.Rows.Count Set getTableArea = range(BASE_ADDRESS, TABLE_LAST_COL & last_row) End Function ' チェック範囲に該当するセルがあれば塗りつぶす Sub colorMatchingCells(ByVal searchArea As range) Dim range As range For Each range In searchArea If containsMatchingExpiry(range) Then range.Interior.Color = vbYellow End If Next End Sub ' 渡された文字列の中に指定年月が含まれているか Function containsMatchingExpiry(ByVal cellString As String) As Boolean Dim entries As Variant Dim item As Variant Dim temp As String containsMatchingExpiry = False ' 該当がなかったらFalseを返す entries = Split(cellString, ",") ' セル内の文字列をカンマで分割 For Each item In entries temp = Replace(Replace(item, " ", ""), " ", "") ' 全角・半角スペースがあれば削除 temp = Replace(temp, vbLf, "") ' セル内改行コードを削除 temp = Split(temp, "*")(0) ' 年月部分を取り出す If isMatchingDate(temp) Then containsMatchingExpiry = True ' 一つでも該当すれば抜ける Exit Function End If Next End Function Function isMatchingDate(ByVal yyyymm As String) As Boolean isMatchingDate = (yyyymm = CHECK_DATE) End Function
