?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