从单元格功能中提取单词

Question

I am using this function to extract a word from a cell.

Function FindWord(Source As String, Position As Integer)
    Dim arr() As String

    arr = VBA.Split(Source, " ")
    xCount = UBound(arr)

    If xCount < 1 Or (Position - 1) > xCount Or Position < 0 Then
        FindWord = ""
    Else
        FindWord = arr(Position - 1)
    End If
End Function

I am looking for a way to extract multiple words instead of just one.

Answer 1

You can use a ParamArray parameter to specify any number of Position parameters.

Something like this:

Function FindWord(Source As String, ParamArray Position())
    Dim arr() As String
    Dim i As Long
    Dim xCount  As Long
    Dim ReturnString As String

    arr = VBA.Split(Source, " ")
    xCount = UBound(arr)

    For i = 0 To UBound(Position)
        If (Position(i) - 1) <= xCount And Position(i) > 0 Then
            ReturnString = ReturnString & " " & arr(Position(i) - 1)
        End If
    Next

    FindWord = Trim$(ReturnString)
End Function

then call it like

=FindWord(A1,3,2,1)

specifying as many Positions as desired

Answer 2

An option would be to use a Regexp to also validate that the strings were actually words.

This function returns a 1D variant array that either returns

• all valid strings if the optional positon sequence is not specified
• the valid strings in the user specified order

Calling the function with
Y = GetWord("I am a test 109 sample", 4, 1)
Puts test in X(1) , I in X(2)

test

Sub TestCode()
Dim Y
Y = GetWord("I am a test 109 sample")
Y = GetWord("I am a test 109 sample", 4, 1)
End Sub

main

Function GetWord(strIn As String, ParamArray Order()) As Variant
Dim objRegex As Object
Dim objRegexMC As Object
Dim objRegexM As Object
Dim X
Dim lngCnt As Long

Set objRegex = CreateObject("vbscript.regexp")

With objRegex
   .Pattern = "\b[a-z]+\b"
   .ignorecase = True
   .Global = True
If .test(strIn) Then
    Set objRegexMC = .Execute(strIn)
    If UBound(Order) < 0 Then
    'get all matches
    ReDim X(1 To objRegexMC.Count)
    For Each objRegexM In objRegexMC
        lngCnt = lngCnt + 1
        X(lngCnt) = objRegexM
    Next
    Else
    ReDim X(1 To UBound(Order()) + 1)
    For lngCnt = 1 To UBound(X)
        If Order(lngCnt - 1) <= objRegexMC.Count Then X(lngCnt) = objRegexMC(Order(lngCnt - 1) - 1)
Next        Next
    End If
GetWord = X
End If
End With
End Function