split string at every nth Word but ignoring counting those in parentheses

[morad medo]

I am using the following UDF to split a long string into rows of predefined number of words in based on input incell "D3".


Public Function SplitOnNth(ByVal inputStr$, ByVal StartPos&, ByVal NumWords&) As String



Dim arr() As String, i As Long, newArr() As String

arr = Split(inputStr)

ReDim newArr(NumWords - 1)



'Arrays are zero-based, but your string isn't. Subtract 1

For i = StartPos - 1 To StartPos + NumWords - 2

If i > UBound(arr) Then Exit For 'Exit if you loop past the last word in string



'ANYTHING IN PARENTHESES SHOULD BE SKIPPED IN WORDS COUNT BUT INCLUDED IN THE WORDS SPLIT



newArr(i - StartPos + 1) = arr(i)

Next



SplitOnNth = Join(newArr, " ")



End Function



For my cells setup please see attached image:

Depending on the value in cell "D3" (in this case 4) the string is split perfectly into rows but because the string has some numbers in parentheses (which could be anywhere in the string) these should be skipped and not be counted in the splitting of the string. These numbers in parentheses, however, should be part of the final result in their exact position as depicted by the image attached. the drawing on the image attached shows the expected result 4 words in each row plus whatever number in the parentheses.



Your help is much appreciated and thanks in advance.

 

[mikerickson]

There are a couple of things that aren't clear:
- how do you want multi-word parenthesis handled. e.g. "one two (alpha beta) three four"
- handeling of improper parenthesisation e.g. "one two (alpha (beta) three four"
- how do you want the result returned, as an array of results or individually.

The UDF NWords will return either a single result if the optional Index argument is specified or a row-wise array if it is omitted.

Function NWords(rawString As String, Optional wordsPerResult As Long = 2, Optional Index As Long = -1)
    Dim rawWords As Variant
    Dim inPointer As Long, outPointer As Long
    Dim foundWords As String, Size As Long
    Dim newResult() As String
    Dim Results() As String, resultCount As Long
    
    rawWords = Split(rawString, " ")
    Size = UBound(rawWords)
    If Size < 0 Then NWords = vbNullString: Exit Function
    
    ReDim Results(1 To Size + 1)
    inPointer = 0
    
    Do
        foundWords = wordsPerResult
        ReDim newResult(0 To Size)
        outPointer = 0
        Do
            newResult(outPointer) = rawWords(inPointer)
            If Not (rawWords(inPointer) Like "(*)") Then
                foundWords = foundWords - 1
            End If
            inPointer = inPointer + 1
            outPointer = outPointer + 1
            
        Loop Until (Size < inPointer) Or (foundWords <= 0)
        
        resultCount = resultCount + 1
        Results(resultCount) = Trim(Join(newResult, " "))
    Loop Until (Size < inPointer)
    
    If Index < 1 Then
        If TypeName(Application.Caller) = "Range" Then
            resultCount = Application.Caller.Cells.Count
        End If
        ReDim Preserve Results(1 To resultCount)
        NWords = Results
    Else
        If Index <= resultCount Then
            NWords = Results(Index)
        Else
            NWords = vbNullString
        End If
    End If
End Function

In your example, you would put =NWords($B$3, $D$3, 1) in G4, =NWords($B$3, $D$3, 2) in G5, etc.
or
Put =NWords($B$3, $D$3, ROW(A1)) in G4 and drag down
or
select G4:G10 and enter the array function =TRANSPOSE(NWords($B$3, $D$3))

 

[Rick Rothstein]

I know you asked for a UDF, but do you really need that? Would a macro that you run when the text in B3 is changed be acceptable?

 

[morad medo]

I cannot thank you enough this is really superb you made my day

 

[morad medo]

I don't mind a macro. This is a learning process that I really enjoy.

 

[Rick Rothstein]

I don't mind a macro. This is a learning process that I really enjoy.

Okay, here is a macro that should work (all it needs is the text in cell B3 and the number of words in cell D3)...

[table="width: 500"]
[tr]
	[td]Sub NWords()
  Dim R As Long, NumWords As Long, S As String, Text As String, Words As Variant
  Text = [SUBSTITUTE(TRIM(B3)," (",CHAR(1)&"(")] & Space([D3])
  If Left(Text, 1) = "(" Then Text = Replace(Text, ") ", ")" & Chr(1), , 1)
  Words = Split(Text)
  Columns("F").ClearContents
  On Error GoTo NoMoreWords
  For R = 0 To UBound(Words) Step [D3]
    [F4].Offset(R / [D3]) = Replace(Join(Application.Transpose(Application.Index(Words, Evaluate("ROW(" & R + 1 & ":" & R + [D3] & ")")))), Chr(1), " ")
  Next
NoMoreWords:
End Sub[/td]
[/tr]
[/table]

 

[morad medo]

Okay, here is a macro that should work (all it needs is the text in cell B3 and the number of words in cell D3)...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub NWords()
  Dim R As Long, NumWords As Long, S As String, Text As String, Words As Variant
  Text = [SUBSTITUTE(TRIM(B3)," (",CHAR(1)&"(")] & Space([D3])
  If Left(Text, 1) = "(" Then Text = Replace(Text, ") ", ")" & Chr(1), , 1)
  Words = Split(Text)
  Columns("F").ClearContents
  On Error GoTo NoMoreWords
  For R = 0 To UBound(Words) Step [D3]
    [F4].Offset(R / [D3]) = Replace(Join(Application.Transpose(Application.Index(Words, Evaluate("ROW(" & R + 1 & ":" & R + [D3] & ")")))), Chr(1), " ")
  Next
NoMoreWords:
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

WOW
very concise and elegant ! ! !
Thank you so much.

[TABLE="class: cms_table, width: 500"]
<tbody>[TR]
[TD]Sub NWords() Dim R As Long, NumWords As Long, S As String, Text As String, Words As Variant Text = [SUBSTITUTE(TRIM(B3)," (",CHAR(1)&"(")] & Space([D3]) If Left(Text, 1) = "(" Then Text = Replace(Text, ") ", ")" & Chr(1), , 1) Words = Split(Text) Columns("F").ClearContents On Error GoTo NoMoreWords For R = 0 To UBound(Words) Step [D3] [F4].Offset(R / [D3]) = Replace(Join(Application.Transpose(Application.Index(Words, Evaluate("ROW(" & R + 1 & ":" & R + [D3] & ")")))), Chr(1), " ") Next NoMoreWords: End Sub

[/TD]
[/TR]
</tbody>[/TABLE]