Convert date in String format to Date format in Excel VBA #VBA #Excel #regexp #datetime

gistfile1.vb

Public Function Str2Date(strInput As String) As Date
    If Trim(strInput & vbNullString) <> vbNullString Then
        If IsDate(strInput) Then
            If Year(strInput) = 1899 Then
                Str2Date = strInput
                Exit Function
            End If
        End If
        
        Dim regEx As New RegExp
        Dim strPattern As String
        Dim y, m, d As String
        strPattern = "([0-9]{1,2})[\./]([0-9]{1,2})[\./]([0-9]{2,4})"
        regEx.Pattern = strPattern
        If regEx.test(strInput) Then
            Set matches = regEx.Execute(strInput)
            y = Right("20" & matches(0).SubMatches(2), 4)
            m = Right("0" & matches(0).SubMatches(1), 2)
            d = Right("0" & matches(0).SubMatches(0), 2)
            If m > 12 Then
                Dim t As String
                t = m
                m = d
                d = t
            End If
        Else
            strPattern = "([0-9]{1,2}).* (.+)[ \.]([0-9]{2,4})"
            regEx.Pattern = strPattern
            If regEx.test(strInput) Then
                Set matches = regEx.Execute(strInput)
                y = Right("20" & matches(0).SubMatches(2), 4)
                d = Right("0" & matches(0).SubMatches(0), 2)
                Dim MonthNameRus
                MonthNameRus = Array("января", "февраля", "марта", "апреля", "мая", "июня", "июля", "августа", "сентября", "октября", "ноября", "декабря")
                m = Application.Match(matches(0).SubMatches(1), MonthNameRus, False)
                If IsError(m) Then
                     m = 1 + 3 * (d - 1)
                     d = 1
                End If
            Else
                strPattern = "([IV]{1,3}).* кв.*[ \.]([0-9]{2,4})"
                regEx.Pattern = strPattern
                If regEx.test(strInput) Then
                    Set matches = regEx.Execute(strInput)
                    RomeNum = Array("I", "II", "III", "IV")
                    Dim q As String
                    q = Application.Match(matches(0).SubMatches(0), RomeNum, False)
                    m = 1 + 3 * (q - 1)
                    d = 1
                    y = Right("20" & matches(0).SubMatches(1), 4)
                Else
                    strPattern = "([0-9]{4})(, |\.|)([0-9]{1,2})"
                    regEx.Pattern = strPattern
                    If regEx.test(strInput) Then
                        Set matches = regEx.Execute(strInput)
                        d = 1
                        m = Right("0" & matches(0).SubMatches(2), 2)
                        y = matches(0).SubMatches(0)
                    Else
                        strPattern = "(.{3,8}) ([0-9]{2,4})"
                        regEx.Pattern = strPattern
                        If regEx.test(strInput) Then
                            Set matches = regEx.Execute(strInput)
                            d = 1
                            Dim MonthNameRus2
                            MonthNameRus2 = Array("Январь", "Февраль", "Март", "Апрель", "Май", "Июнь", "Июль", "Август", "Сентябрь", "Октябрь", "Ноябрь", "Декабрь")
                            m = Application.Match(matches(0).SubMatches(0), MonthNameRus2, False)
                            y = Right("20" & matches(0).SubMatches(1), 4)
                        Else
                            strPattern = "([0-9]{1,2}).([0-9]{2,4})"
                            regEx.Pattern = strPattern
                            If regEx.test(strInput) Then
                                Set matches = regEx.Execute(strInput)
                                d = 1
                                m = matches(0).SubMatches(0)
                                y = Right("20" & matches(0).SubMatches(1), 4)
                            End If
                        End If
                    End If
                End If
            End If
        End If
        If Trim(y & vbNullString) <> vbNullString And Trim(m & vbNullString) <> vbNullString Then
            Str2Date = DateSerial(y, m, d)
        End If
    End If
End Function