Microsoft Access 掲示板

Excelのファイル名から日付を取得する

正規表現によるパターンパッチングを行う場合。

Function FindDate(Expression As String) As Variant
    
    FindDate = Null
    
    If Expression = "" Then
        Exit Function
    End If

    Dim objRegExp As Object
    Dim objMatches As Object
    Dim objMatch As Object
    Dim strPattern As String
    Dim strMatchValue As String
    
    Set objRegExp = CreateObject("VBScript.RegExp")
    
    strPattern = "\d+(-|/|\.)\d{1,2}(-|/|\.)\d+"
    
    With objRegExp
        .Pattern = strPattern
        .IgnoreCase = True
        .Global = True
        Set objMatches = .Execute(Expression)
    End With
    
    For Each objMatch In objMatches
        strMatchValue = Replace(objMatch.Value, ".", "/", 1, -1, vbTextCompare)
        If IsDate(strMatchValue) = True Then
            FindDate = CDate(strMatchValue)
            Exit For
        End If
    Next
    
   Set objMatches = Nothing
   Set objRegExp = Nothing

End Function

'呼び出し例
Sub Test1()

    Dim strFullPath As String
    Dim strFileName As String
    
    strFullPath = "C:\Users\中略\発注書(2023-12.19).xls"

    strFileName = Dir(strFullPath)
    
    If strFileName = "" Then
        MsgBox "ファイル'" & strFullPath & "'が見つかりません。", _
               vbExclamation, _
               "ファイル参照エラー"
        Exit Sub
    End If
    
    Dim varDate As Variant
    
    varDate = FindDate(strFileName)

    If IsNull(varDate) Then
        MsgBox "ファイル名'" & strFileName & "'には日付データに変換可能な文字列は含まれていません。", _
               vbExclamation, _
               "ファイル命名規則エラー"
    Else
        MsgBox "ファイル名'" & strFileName & "'から日付 " & Format(varDate, "yyyy/mm/dd") & "を取得しました。", _
               vbInformation, _
               "成功"
    End If

End Function