const VOWEL = "/аеиоуыэюя/"
const PERFECTIVEGROUND = "/((ив|ивши|ившись|ыв|ывши|ывшись)|((?<=(ая))(в|вши|вшись)))/"
const REFLEXIVE = "/(с(яь))/"
const ADJECTIVE = "/(ее|ие|ые|ое|ими|ыми|ей|ий|ый|ой|ем|им|ым|ом|его|ого|ему|ому|их|ых|ую|юю|ая|яя|ою|ею)/"
const PARTICIPLE = "/((ивш|ывш|ующ)|((?<=(ая))(ем|нн|вш|ющ|щ)))/"
const VERB = "/((ила|ыла|ена|ейте|уйте|ите|или|ыли|ейх.й|ил|ыл|им|ым|ен|ило|ыло|ено|ят|ует|уют|ит|ыт|ены|ить|ыть|ишь|ую|ю)|((?<=(ая))(ла|на|ете|йте|ли|й|л|ем|н|ло|но|ет|ют|ны|ть|ешь|нно)))/"
const NOUN = "/(а|ев|ов|ие|ье|е|иями|ями|ами|еи|ии|и|ией|ей|ой|ий|й|иям|ям|ием|ем|ам|ом|о|у|ах|иях|ях|ы|ь|ию|ью|ю|ия|ья|я)/"
const RVRE = "/^(.*?(аеиоуыэюя))(.*)/"
const DERIVATIONAL = "/(^аеиоуыэюя)(аеиоуыэюя)+(^аеиоуыэюя)+(аеиоуыэюя).*(?<=о)сть?/"

Option Explicit
Dim Stem_Cache As New Collection
Const VOWEL = "аеиоуыэюя"
Const PERFECTIVEGROUND = "((ив|ивши|ившись|ыв|ывши|ывшись)|((?<=[ая])(в|вши|вшись)))"

Const PERFECTIVEGROUND1 = "(ив|ивши|ившись|ыв|ывши|ывшись)$"
Const PERFECTIVEGROUND2 = "[ая](в|вши|вшись)$"

Const REFLEXIVE = "(с[яь])"
Const ADJECTIVE = "(ее|ие|ые|ое|ими|ыми|ей|ий|ый|ой|ем|им|ым|ом|его|ого|ему|ому|их|ых|ую|юю|ая|яя|ою|ею)"

Const PARTICIPLE = "((ивш|ывш|ующ)|((?<=[ая])(ем|нн|вш|ющ|щ)))"
Const VERB = "((ила|ыла|ена|ейте|уйте|ите|или|ыли|ейх.й|ил|ыл|им|ым|ен|ило|ыло|ено|ят|ует|уют|ит|ыт|ены|ить|ыть|ишь|ую|ю)|((?<=[ая])(ла|на|ете|йте|ли|й|л|ем|н|ло|но|ет|ют|ны|ть|ешь|нно)))"
    
Const NOUN = "(а|ев|ов|ие|ье|е|иями|ями|ами|еи|ии|и|ией|ей|ой|ий|й|иям|ям|ием|ем|ам|ом|о|у|ах|иях|ях|ы|ь|ию|ью|ю|ия|ья|я)"
Const RVRE = "^(.*?[аеиоуыэюя])(.*)"
Const DERIVATIONAL = "[^аеиоуыэюя][аеиоуыэюя]+[^аеиоуыэюя]+[аеиоуыэюя].*(?<=о)сть?"

Private Function s(s1 As String, re As String, toA As String) As Boolean
Dim orig As String
    orig = s1
    objRegexp.Pattern = re
    s1 = objRegexp.Replace(s1, toA)
    s = orig <> s1
End Function

Private Function m(s As String, re As String) As Boolean
    objRegexp.Pattern = re
    m = objRegexp.Test(s)
End Function
    
Function stem_word(word As String) As String
Dim objRegexp As New RegExp
Dim p As MatchCollection
Dim start
Dim rv As String
Dim stem As String

    word = LCase(word)
    word = Replace(word, "ё", "е")
    On Error Resume Next
    rv = Stem_Cache(word)
    If Err.Number =  0  Then
        stem_word = rv
        Exit Function
    End If
    On Error GoTo  0 
    stem = word
    Do
        objRegexp.Pattern = RVRE
        Set p = objRegexp.Execute(word)
        If p.Count =  0  Then Exit Do
        
        'здесь пока вишу
        'start = p(1)
        'rv = p(2)
        If Len(rv) =  0  Then Exit Do

        'Step 1
        If Not s(rv, PERFECTIVEGROUND, "") Then
            Call s(rv, REFLEXIVE, "")
            If (s(rv, ADJECTIVE, "")) Then
                Call s(rv, PARTICIPLE, "")
            Else
                If (Not s(rv, VERB, "")) Then Call s(rv, NOUN, "")
            End If
        End If
    
        'Step 2
        Call s(rv, "и", "")
    
        'Step 3
        If m(rv, DERIVATIONAL) Then Call s(rv, "ость?", "")
    
        'Step 4
        If (Not s(rv, "ь", "")) Then
            Call s(rv, "ейше?", "")
            Call s(rv, "нн", "н")
        End If
        stem = start.rv
    Loop
    Stem_Cache.Add stem, word
    stem_word = stem
End Function

        .Pattern = "<([^>]*)>"
        s = .Replace(LCase$(DocText), " ")
        .Pattern = "title=([^>]*)>" 'предыдущий паттерн почему-то игнорирует title в <a href="урл" title="текст">
        s = .Replace(s, "")
        .Pattern = "[^а-я]"
        s = .Replace(s, " ")

    oRegExp.Pattern = "[0-3]\d\x2e[0-1]\d\x2e\d\d\d\d"
    Debug.Print oRegExp.Replace(s, " ")