?STWRE2("","")
~info;;ws~
~com~
~com;;net;;org~
~net;;org;;ws;;su~
~su~

Function STWRE2( _
                ByVal s0$, _
                ByVal sText$, _
                Optional ByVal sValSep = ",", _
                Optional ByVal sTXTSep$)

''Const SWS$ = "\s"
Const SWS$ = "(?:\s|\s)"

Dim clt As Collection, re, mt
Dim i%, ii%
Dim pos0%, pos%
Dim sFind

' ### for test ONLY -->
    s0$ = "com,net,org,info,su,ws": sValSep = ","
    
    sText = _
    "ws;;" + vbNewLine + _
    "info;;ws" + vbNewLine + _
    "com" + vbNewLine + _
    "com;;org;;info;;btr" + vbNewLine + _
    "com;;net;;org" + vbNewLine + _
    "com;;org;;info;;com" + vbNewLine + _
    "net;;org;;ws;;su" + vbNewLine + _
    "su"
    sTXTSep = ";;"
' ### for test ONLY <--

sText = " " + sText + " "
If sTXTSep = "" Then sTXTSep = sValSep

re = Split(s0, sValSep)
Set clt = New Collection

' сборка паттерна, заполнение коллекции
For i = UBound(re) To  1  Step - 1 
    clt.Add CInt(i), re(i)
    sFind = "|" & re(i) & sFind
Next
clt.Add CInt(i), re(i)
ii = UBound(re) -  1 

sFind = "(" + re(i) + sFind + ")" + _
"(" + sTXTSep + "(" + Mid$(sFind,  2 ) + ")){0,1}" + _
"(" + sTXTSep + "(" + Mid$(sFind,  2 ) + ")){0," + CStr(ii) + "}"

''sFind = SWS + sFind + SWS
sFind = SWS + "(" + sFind + ")" + SWS

Erase re

' проверка на
Set re = CreateObject("VBScript.RegExp")
re.Global = - 1 : re.MultiLine = - 1 : re.IgnoreCase = - 1 : re.Pattern = sFind
Set mt = re.Execute(sText)
If mt.Count >  0  Then
    For i =  0  To mt.Count -  1 
        pos0 =  1 
        
        ''If mt(i).SubMatches.Count > 1 Then
        If mt(i).SubMatches.Count >  2  Then
            
            ''If mt(i).SubMatches(1) > "" Then
            If mt(i).SubMatches( 2 ) > "" Then
            
            ''pos0 = clt(mt(i).SubMatches(0))
            pos0 = clt(mt(i).SubMatches( 1 ))
            
            ''For ii = 2 To mt(i).SubMatches.Count - 1 Step 2
            For ii =  3  To mt(i).SubMatches.Count -  1  Step  2 
            
                If mt(i).SubMatches(ii) > "" Then
                    pos = clt(mt(i).SubMatches(ii))
                    If pos <= pos0 Then
                            pos0 =  0 : Exit For 'ii, SubMathes
                    Else:   pos0 = pos
                    End If
                End If
            Next ii 'SubMatches.Count
            End If
        End If
        
        ''If pos0 > 0 Then Debug.Print "~" + Trim(Replace(Replace(mt(i), vbCr, ""), vbLf, "")) + "~"
        If pos0 >  0  Then Debug.Print "~" + mt(i).SubMatches( 0 ) + "~"
        
    Next i
Else
    Debug.Print "WRONG TEXT"
End If
Set clt = Nothing: Set mt = Nothing: Set re = Nothing
End Function

?STWRE3("","")
~info~ 0 
~info;;ws~ 1 
    inexact accordance:     ~jp;;su~ 2 
~com~ 3 
    inexact accordance:     ~org;;ws;;net~ 4 
~org;;ws;;info~ 5 
~com;;net;;org~ 6 
    inexact accordance:     ~net;;org;;su;;net~ 7 
~net;;org;;su;;de;;gov;;jp~ 8 
~net;;org;;ws;;su;;de;;gov;;jp~ 9 
~su~ 10 

Function STWRE3(ByVal s0$, ByVal sText$, Optional ByVal sValSep = ",", Optional ByVal sTXTSep$)

Const iMMATCH% =  3           ' ==.SubMatches.Count-1 "чернового" RE
                            ' зависит ТОЛЬКО от паттерна (не считая машины RE)

Const SWS$ = "(?:\s|\s)"    ' аффикс паттерна "чернового" RE

Dim clt As Collection, re, mt, mt2
Dim i%, ii%, pos0%, pos%, pos1%, j%
Dim sFind$, sFind2$

' ### for test ONLY -->
    s0$ = "com,net,org,info,su,ws,de,gov,jp": sValSep = ","
    sText = _
    "info" + vbNewLine + _
    "ws;;" + vbNewLine + _
    ";;de" + vbNewLine + _
    "info;;ws" + vbNewLine + _
    "jp;;su" + vbNewLine + _
    "com" + vbNewLine + _
    "org;;ws;;net" + vbNewLine + _
    "org;;ws;;info" + vbNewLine + _
    "com;;net;;org" + vbNewLine + _
    "com;;org;;info;;btr" + vbNewLine + _
    "net;;org;;su;;net" + vbNewLine + _
    "net;;org;;su;;de;;gov;;jp" + vbNewLine + _
    "net;;info;;zzz;;su;;de;;jp" + vbNewLine + _
    "net;;org;;ws;;su;;de;;gov;;jp" + vbNewLine + _
    "su"
    sTXTSep = ";;"
' ### for test ONLY <--

sText = " " + sText + " "
If sTXTSep = "" Then sTXTSep = sValSep


re = Split(s0, sValSep)
Set clt = New Collection

' сборка паттерна "чернового" RE, заполнение коллекции "словами"
For i = UBound(re) To  1  Step - 1 
    clt.Add CInt(i), re(i)
    sFind = "|" + re(i) + sFind
Next
clt.Add CInt(i), re(i)
ii = UBound(re) -  1 

sValSep = "(?:" + sTXTSep + "|" + sTXTSep + ")"

sFind = "(" + re(i) + sFind + ")" + _
        "(" + sValSep + "(" + Mid$(sFind,  2 ) + "))*"

sFind = SWS + "(" + sFind + ")" + SWS                           ' паттерн1 ("черновой")
sFind2 = "((?!" + sTXTSep + "|" + sTXTSep + "))+" + sTXTSep     ' паттерн2 ("чистовой")

Erase re

' проверка на
Set re = CreateObject("VBScript.RegExp")
re.Global = - 1 : re.MultiLine = - 1 : re.IgnoreCase = - 1 : re.Pattern = sFind

Set mt = re.Execute(sText)
If mt.Count >  0  Then
    
    re.Pattern = sFind2

    ' обработка наборов "слов", прошедших "черновую" проверку
    For i =  0  To mt.Count -  1 
        pos0 =  0                            ' флаг полного соответствия "шаблону"
    
    If mt(i).SubMatches(iMMATCH) > "" Then ' в набор более одного слова
                                            ' (!) условие зависит от паттерна "чернового" RE
    
        pos0 = clt(mt(i).SubMatches( 1 ))
        pos1 = clt(mt(i).SubMatches(iMMATCH))
        
        ' проверка порядка следования "слов"
        If pos1 <= pos0 Then
            ' неверный порядок (по первому-последнему элементам)
            pos0 = - 1 
        ElseIf pos1 - pos0 >  1  Then
            
            Set mt2 = re.Execute(mt(i).SubMatches( 0 ) + sTXTSep)
            j = mt2.Count -  2 : ii =  1 
            
            Do While ii <= j
                
                pos = clt(mt2.matches(ii))
                If pos <= pos0 Or pos >= pos1 Then
                    pos0 = - 1 : Exit Do
                
                ElseIf ii < j Then
                
                    pos0 = pos: pos = clt(mt2.matches(j))
                    If pos <= pos0 Or pos >= pos1 Then
                        pos0 = - 1 : Exit Do
                    Else
                        pos1 = pos
                    End If
                End If
                
                ii = ii +  1 : j = j -  1 
            Loop ' While ii <= j
            
        End If ' pos1 < pos0
    End If ' mt(i).SubMatches(iMMATCH) > ""
    
    sFind = "~" + mt(i).SubMatches( 0 ) + "~" + CStr(i)
    'If pos0 >= 0 Then Debug.Print sFind Else Debug.Print vbTab; "inexact accordance: ", sFind
    If pos0 <  0  Then Debug.Print vbTab; "inexact accordance: ",
    Debug.Print sFind
    
    Next i ' mt.Count
Else
    Debug.Print "WRONG TEXT"
End If

Set clt = Nothing: Set mt = Nothing: Set mt2 = Nothing: Set re = Nothing
End Function

' **********************************************
Function STWRE4(ByVal s0$, ByVal sText$, _
                Optional ByVal sValSep = ",", Optional ByVal sTXTSep$)

On Error GoTo Err_Exit_F

Const iMMATCH% =  3           ' ==.SubMatches.Count-1 "чернового" RE
                            ' зависит ТОЛЬКО
                            ' от паттерна (не считая машины RE)

Const SWS$ = "(?:\s)"       ' аффикс паттерна "чернового" RE

Dim clt, re, mt, mt2
Dim i%, ii%
Dim pos0%, pos%, pos1%, j%
Dim sFind$, sFind2$


sText = " " + sText + " "
If sTXTSep = "" Then sTXTSep = sValSep

re = Split(s0, sValSep)
Set clt = New Collection

' сборка паттерна "чернового" RE, заполнение коллекции "словами"
For i = UBound(re) To  1  Step - 1 
    clt.Add CInt(i), re(i)
    sFind = "|" + re(i) + sFind
Next
clt.Add CInt(i), re(i)


sValSep = "(?:" + sTXTSep + "|" + sTXTSep + ")"

sFind = "(" + re(i) + sFind + ")" + _
        "(" + sValSep + "(" + Mid$(sFind,  2 ) + "))*"

sFind = SWS + "(" + sFind + ")" + SWS                       ' паттерн "черновой"
sFind2 = "(?:" + sTXTSep + ")(.+?)(?=" + sTXTSep + ")"      ' паттерн2 "чистовой"


Erase re

' поиск соответствия "черновому" паттерну по всему тексту
Set re = CreateObject("VBScript.RegExp")
re.Global = - 1 : re.MultiLine = - 1 : re.IgnoreCase = - 1 
re.Pattern = sFind                          ' поиск по "черновому" паттерну

Set mt = re.Execute(sText)
If mt.Count >  0  Then
    
    re.Pattern = sFind2                     ' переключение RE на "чистовой" паттерн

    ' обработка наборов "слов", прошедших "черновую" проверку
    For i =  0  To mt.Count -  1 
        pos0 =  0                            ' флаг полного соответствия "шаблону"
    
    If mt(i).SubMatches(iMMATCH) > "" Then
    ' в набор более одного слова (!) условие зависит от паттерна "чернового" RE
    
        pos0 = clt(mt(i).SubMatches( 1 ))             ' первое слово в "черновом" наборе
        pos1 = clt(mt(i).SubMatches(iMMATCH))       ' последнее слово в "черновом" наборе
        
        ' проверка порядка следования "слов"
        If pos1 <= pos0 Then
            ' неверный порядок (по первому-последнему элементам)
            pos0 = - 1 
            
        ElseIf pos1 - pos0 =  1  Then
            ' набор должен состоять из двух элементов
            If mt(i).SubMatches( 1 ) + sTXTSep + _
                 mt(i).SubMatches(iMMATCH) <> mt(i).SubMatches( 0 ) Then _
            pos0 = - 1 
        
        Else
            
            sText = sTXTSep + mt(i).SubMatches( 0 ) + sTXTSep
            Set mt2 = re.Execute(sFind)
            j = mt2.Count -  2 : ii =  1 
            
            Do While ii <= j
                
                pos = clt(mt2(ii).SubMatches( 0 ))
                If pos <= pos0 Or pos >= pos1 Then
                    pos0 = - 1 : Exit Do
                
                ElseIf ii < j Then
                    pos0 = pos: pos = clt(mt2(j).SubMatches( 0 ))
                    If pos <= pos0 Or pos >= pos1 Then
                        pos0 = - 1 : Exit Do
                    Else
                        pos1 = pos
                    End If
                End If
                
                ii = ii +  1 : j = j -  1 
            Loop ' While ii <= j

        End If ' pos1 <= pos0
    End If ' mt(i).SubMatches(iMMATCH) > ""
    
    sFind = "~" + mt(i).SubMatches( 0 ) + "~" + CStr(i)
    If pos0 <  0  Then Debug.Print vbTab; "inexact accordance: ",
    Debug.Print sFind
    
    Next i ' mt.Count
Else
    Debug.Print "WRONG TEXT"
End If

Norm_Exit_F:
Set clt = Nothing: Set mt = Nothing: Set mt2 = Nothing: Set re = Nothing
Exit Function

Err_Exit_F:
    Select Case Err.Number
    Case  457 : sFind = "повтор слова в словаре: ~" + re(i) + "~"
    Case Else
        sFind = "RT error: '" + Err.Number + "'" + vbNewLine + Err.Description
    End Select
    Debug.Print "(!) ", sFind
    Resume Norm_Exit_F
End Function