【ExcelVBA】yymmddとかmmddで日付入力、hhmmで時刻入力

Excelよ、いい加減yymmddとかmmddで日付入力させなさいよ、と思って作ってたやつ

年末年始で来年の1月を入力する時期だからご注意を的な通知があったので紹介しようと思ったら、まだ挙げてなかったのでもしよかったら

この時期になるとエクセルに2025年1月の日付を入力したつもりが2024年1月の日付だった…というミスが起こります

西暦の入力は省略できませんが、先頭の『20』は省けます
『25/1/1』や『25-1-1』と入力すると日付が『2025/1/1』になります

— 筒井.xls@エクセル関数擬人化本著者 (@Tsutsui0524) December 25, 2024

ThisWorkbook：ショートカット付与

Private Sub Workbook_Open()
  Application.OnKey "^%~", "hhmmで時刻入力" 'Ctrl+Alt+Enter
  Application.OnKey "%~", "mmddかyymmddで日付入力" 'Alt+Enter
End Sub

標準モジュール：mmddかyymmddで日付入力

Sub mmddかyymmddで日付入力()
   Dim buf

   buf = InputBox("4桁または6桁で日付を入力してください" & vbCrLf & "（mmdd形式またはyymmdd形式）")

    Select Case True
    '先頭に0が付く場合は桁数が減るので各パターン用意
        Case buf = "": GoTo Cancel
        Case buf Like "####"
            buf = Year(Date) & "/" & Left(buf, 2) & "/" & Right(buf, 2)
        Case buf Like "######"
            buf = Left(Year(Date), 2) & Left(buf, 2) & "/" & Mid(buf, 3, 2) & "/" & Right(buf, 2)
        Case Else
            MsgBox "4桁or6桁の数値で入力してください"
            buf = ActiveCell.Value
    End Select
    ActiveCell.Value = buf
Cancel:
End Sub

標準モジュール：hhmmで時刻入力

時刻入力も地味にコロン（:）入れるの面倒なのでついでに

Sub hhmmで時刻入力()
    Application.EnableEvents = False '無限ループ対策

    On Error Resume Next
    flag = True 'Falseなら見積等計算プロシージャで自動計算させない

    buf = InputBox("4桁で時刻を入力してください" & vbCrLf & "（hhmm形式）")


'        If ActiveCell.NumberFormatLocal = "h:mm;@" Then
            Select Case True
            '先頭に0が付く場合は桁数が減るので各パターン用意
            Case buf Like "#"
                buf = "00:0" & buf
            Case buf Like "##"
                buf = "00:" & buf
            Case buf Like "###"""
                buf = "0" & Left(buf, 1) & _
                        ":" & Right(buf, 2)
            Case buf Like "####"
                buf = Left(buf, 2) & _
                        ":" & Right(buf, 2)
            Case buf Like "#:##", "##:##"    '何もしない
            Case buf = "": flag = False      '見積等計算プロシージャで自動計算させない
            Case Else
                MsgBox "4桁の数値か時刻形式で入力してください"
                flag = False
                buf = ""
            End Select  'True
'        End If  'NumberFormatLocal

    ActiveCell.Value = buf
    Application.EnableEvents = True

End Sub