Поиск и вывод Даты внутри текста + Подсчёт кол-ва дат в строкеПо материалам: 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 знаков ?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
|
|||
L.E. 07.05.2023 |