VBA, MS Access MS Access в примерах

Поиск и вывод Даты внутри текста + Подсчёт кол-ва дат в строке

По материалам: https://www.cyberforum.ru/ms-access/thread3077127.html#post16753225

Public Function GetDateFromText(vValue) As Variant
'Вывод Даты из текста
'- Когда дата отделена определёнными символами, тут символами подчёркивания.
Const sDateDelimiter$ = "_"
Dim iVal%, sArr$()
    sArr = Split(vValue & "", sDateDelimiter)
    For iVal = LBound(sArr) To UBound(sArr)
        If IsDate(sArr(iVal)) Then
            GetDateFromText = DateValue(sArr(iVal))
            Exit For
        End If
    Next iVal
End Function



Универсальный вариант:

Public Function GetOnlyDate(stroka, Optional sDateDelimiter = ".")
'Поиск и вывод Даты из текста
    Dim objRegExp As Object, oMatches
    Dim iVal%, sVal$, vVal
    
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = True
    
    'Тут так:
    '   \d{1,2} = одно или двухзначное число
    '   [\.,/-] = Разделитель - любой из перечисленных символов
    objRegExp.Pattern = "\d{1,2}[\.,/-]\d{1,2}[\.,/-]\d{2,4}"
        
    Set oMatches = objRegExp.Execute(stroka)
    For iVal = 0 To oMatches.Count - 1
        vVal = Trim(oMatches(iVal))
        If Left(vVal, 1) = "(" Then vVal = vVal & ")"
        sVal = sVal & "," & vVal
    Next
    If Not sDateDelimiter = "." Then sVal = Replace(sVal, sDateDelimiter, ".")
    GetOnlyDate = Mid(sVal, 2)
    Set objRegExp = Nothing
    Set oMatches = Nothing
End Function

Пробуем в Immediate

?GetOnlyDate("... фкур птапч... 12.04.2019 или 12.04.19 ... увр ап прона...")
12.04.2019,12.04.19
 
?GetOnlyDate("С-АМ_20-01-2022_1250", "-")
20.01.2022

\d{1,2} - цифры до 2 знаков
[\.,/-] - любые символы из перечисленных
\d{2,4} - цифра 2-4 символа


?OnlyDate("... фкур птапч... 12-04,24 ап прона...")
12-04,24



Подсчёт дат в строке

Public Function CountDates(vStroka) As Integer
'Подсчёт дат в строке
'----------------------------------------------------------------
Dim objRegExp As Object, oMatches  As Object
On Error GoTo CountDates_Err
    
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = True
    
    objRegExp.Pattern = "\d{1,2}[./-]\d{1,2}[./-]\d{2,4}"
    
    Set oMatches = objRegExp.Execute(vStroka)
    CountDates = oMatches.Count

CountDates_End:
    On Error Resume Next
    Set objRegExp = Nothing
    Set oMatches = Nothing
    Err.Clear
    Exit Function

CountDates_Err:
    CountDates = -1
    Err.Clear
    Resume CountDates_End
End Function

Назад ToTop
L.E. 07.05.2023
Рейтинг@Mail.ru