ちょっとフォーマットが不統一でも無理やり日付解析

VBA EXCEL

日付データのフォーマットが、全角半角混在、区切り文字がスラッシュや漢字(年月日)やドット混在、日付シリアル値と文字列の混在などで、組み込み関数や多少のifネストでは日付として解析する事が困難な場合に、シリアル値に統一するVBA。
toDate()が変換本体部、それをワークシートから呼び出しやすいようラッピングしたのがtoDateOpe()。

既知の問題点としては、

  • 例えば「平成元年」とだけあると「1989/1/1」のシリアル値に変換するが平成元年は「1989/1/8」以後である。
  • 1900/1/1以前の日付をDate型でセルに代入するとエラーになるので、この場合はシリアル値ではなく、システム規定の日付表現で文字列として返す。

2008-09-27 Split関数で一部書き直し。

' 与えられた文字列を出来るだけ日付として解釈し、シリアル値を返す
Function toDate(text)
    
    '半角、大文字に統一
    txt = UCase(StrConv(text, vbNarrow))
    
    '年号の特定
    If (InStr(txt, "明") > 0 Or InStr(txt, "M") > 0) Then
        nenngou = "M"
    ElseIf (InStr(txt, "大") > 0 Or InStr(txt, "T") > 0) Then
        nenngou = "T"
    ElseIf (InStr(txt, "昭") > 0 Or InStr(txt, "S") > 0) Then
        nenngou = "S"
    ElseIf (InStr(txt, "平") > 0 Or InStr(txt, "H") > 0) Then
        nenngou = "H"
    ElseIf (Val(txt) > 1900 And Val(txt) < 2020) Then
        nenngou = ""
    Else
        'MsgBox "エラー発生、年号が特定できません、text=" & text
        Exit Function
    End If
    
    '元年は"1 "に置き換え
    txt = Replace(txt, "元年", "1 ", 1, 1)
    '「平成元年」と書かずに例えば「平元6月」とはあまり書かないけど一応
    txt = Replace(txt, "元", "1 ", 1, 1)

    '数字以外を空白に置き換える
    txt2 = ""
    For i = 1 To Len(txt)
        a = Mid(txt, i, 1)
        If (InStr("0123456789", a) > 0) Then
            txt2 = txt2 & a
        ElseIf (Right(txt2, 1) <> " ") Then
            txt2 = txt2 & " "
        End If
    Next i
    txt2 = Trim(txt2)
    
    '数字部分が三つあるなら年、月、日の順に並んでいるとみなす
    '月、日は省略されていれば1とみなす
    txt3 = Split(txt2, " ")
    If (UBound(txt3) >= 2) Then hi = txt3(2) Else hi = "1"
    If (UBound(txt3) >= 1) Then tuki = txt3(1) Else tuki = "1"
    If (UBound(txt3) >= 0) Then
        nen = txt3(0)
        toDate = DateValue(nenngou & nen & "/" & tuki & "/" & hi)
        '1900年1月1日以前のシリアル値を返すと、
        'セルのValueプロパティに代入するときにエラーが発生する。
        'この場合はシステム規定のフォーマットでの文字列として返す。
        If (toDate < DateValue("1900/1/1")) Then toDate = CStr(toDate)
        Exit Function
    End If
    
    'MsgBox "エラー発生､日付に変換できません､text = " & text
    toDate = ""
    
End Function

' 選択範囲を日付を表す文字列とみなし、その右の列にシリアル値を入力する。
' 1900/1/1以前の日付はシリアル値では返せないようなので文字列として返す。
Sub toDateOpe()
    For Each xCell In Selection
        xCell.Cells(1, 2).Value = toDate(xCell.Value)
    Next xCell
End Sub