Dim MyString As String
Dim SplitArray
Dim OutPutString As String

Dim i As Long, j As Long

Private Sub Form_Load()
    ' здесь твоё предложение:
    MyString = "Эждлогтрнпекуцыворпeвс вот такое слово"
    ' перевели все буквы в прописные:
    MyString = LCase(MyString)
    'разбиваем предложение на отдельные слова, разделитель слов - пробел
    'слова будут собраны в массиве SplitArray
    SplitArray = Split(MyString, " ")
    ' начиная со второго слова (первое проверять не будем )
    For i = 1 To UBound(SplitArray)
        'проверяем каждую букву слова
        For j = 1 To Len(SplitArray(i))
            'содержится она в первом слове или нет
            If InStr(SplitArray(0), Mid(SplitArray(i), j, 1)) = 0 Then
                'если не содержится, переходим к следующему слову
                GoTo lbl_next
            End If
            'если дошли до сюда, значит буква есть в первом слове, смотрим следующую букву
        Next j
        ' а если мы дошли до сюда, значит все буквы слова есть в первом слове
        ' и запишем это слово в выходную переменную(опять же с разделителем " " - пробел)
        OutPutString = OutPutString & SplitArray(i) & " "
lbl_next:
    'здесь переход к следующему слову предложения
    Next i
    ' в  выходной переменной отрезаем лишний пробел.
    OutPutString = Trim$(OutPutString)
    'в ней теперь содержатся все слова, состоящие только из букв первого слова
    Debug.Print OutPutString
    'можно снова разбить эту переменную на отдельные слова и запихать в массив
    SplitArray = Split(OutPutString, " ")
    ' и получить каждое слово массива в отдельности:
    For i = 0 To UBound(SplitArray)
        MsgBox SplitArray(i)
    Next i
End Sub

Ответить

Нужна ссылка на Microsoft VBScript Regular Expression 5.5, которая устанавливается с 5-ым. InternetExplorer-ом.

Private Sub Form_Load()

Dim str As String

Dim first3char As String

Dim rx As New RegExp

Dim amath As Match

Dim mathColl As MatchCollection

str = "abc: abc1; abc-2, noabc abc3a's."

first3char = Left(str, 3)

Debug.Print vbCrLf & first3char

With rx

.Global = True

.IgnoreCase = False

.Pattern = "\s?(" & first3char & "[^\s]+)[\.|,|;|:]\s?"

End With

Set mathColl = rx.Execute(str)

For Each amath In mathColl

Debug.Print amath.SubMatches(0)

Next

End Sub

Ответить

второму ответу.

Свойство IgnoreCase объекта rx должно быть "True".

Ответить

Ко второму ответу .

Я прошу прщщения, patern должен иметь следующий вид -

"\s?(" & first3char & "[^\s]+)[;|:|\.|,]?\s?"

Ответить

Спасибо, но:

-По первому:

Отображается только два слова "вот, слово" а должно еще и "такое"

-По второму:

Извини но вообще ничего не понял.

Ответить

Спасибо, но:

-По первому:

Отображается только два слова "вот, слово" а должно еще и "такое"

-По второму:

Извини но вообще ничего не понял.

Ответить

Ответить

Вот еще способ:

Private Sub Form_Load()

Dim str As String

Dim firstWord As String

Dim rx As New RegExp

Dim amath As Match

Dim mathColl As MatchCollection

Dim char As String

Dim char_array()

Dim bFound As Boolean

Debug.Print

Set dic = New Collection

str = "abc cba bdfg kjhgf adire "

With rx

.Global = True

.IgnoreCase = True

End With

rx.Pattern = "^[^\s]+\s"

Set mathColl = rx.Execute(str)

firstWord = mathColl(0)

For i = 1 To Len(firstWord)

char = Mid(firstWord, i, 1)

ReDim Preserve char_array(i - 1)

char_array(i - 1) = char

Next

rx.Pattern = "\s?([^\s]+)\s?"

Set mathColl = rx.Execute(str)

For Each amath In mathColl

For i = 0 To UBound(char_array)

rx.Pattern = char_array(i)

If rx.Test(amath.SubMatches(0)) Then

Debug.Print amath.SubMatches(0)

Exit For

End If

Next

Next

End Sub

Ответить