vba mapping function behaving unexpectedly - arrays

Question

why the function below works sometimes and fails at others?
The function idea
a string gets passed to this function by a user or a procedure
the string will be split by multiple delimiters into an array of words
each word is cleaned from non-letter characters except for the characters (dash and single quote mark inside the word) an example of words having these two char. would be (man's spirit, life-loving)
if the single quote marks are found surrounding the word, they get trimmed too
after processing each word in the string, and if the word is not empty it gets stored into the array Along with it's starting position and end position
the start and end positions refer to the position of that word within the input string and excluding any non-letter characters that might surround the word.
Here's the code
Sub test()
Dim d$: d = ThisDocument.Range.Text
Dim Arr(), i&
Arr = ExtractWordsFromDoc_2(d)
For i = 0 To UBound(Arr)
ThisDocument.Range(Arr(i)(1) - 1, Arr(i)(2)).HighlightColorIndex = wdBrightGreen
Next
End Sub
Function ExtractWordsFromDoc_2(ByRef doc As Document, Optional ByVal Delimiters)
' Take a string, and return it as a one dimensional array of individual arrys, each array
' has three values (single delimited string, start range of delimited str, end range of delimited str)
' the input string is delimited by any of several characters. None of those characters are returned in
' the result. Provide a default list of Delimiters, which Should come from registry.
' But allow override.
'===================================================================================================================
Dim InputString$: InputString = doc.Range.Text
'return an array of empty string when input string is empty
If InputString = "" Then
ExtractWordsFromDoc_2 = Array("", 0, 0)
Exit Function
End If
'===================================================================================================================
Dim DelimitList As Variant, ArrayOfWords() As Variant, TmpArr() As Variant
Dim OneChar$, TempWord$, WordCount&, InputStringLength&, CharIndex&, ArrUbound&
'===================================================================================================================
'if delimiters are missing, We should get these from a Registry
If IsMissing(Delimiters) Then
DelimitList = Chr(34) & Chr(147) & Chr(148) & Chr(32) & "," & "." & vbCr & vbTab & "/" & "!" & "|" & ";" & ")" & "(" & "?"
'Chr(34)= straight double quotes mark
'Chr(147) & Chr(148) =opening and closing double quotes marks
'Chr(32) = space
Else
DelimitList = Delimiters 'user can override if needed
End If
'===================================================================================================================
InputStringLength = Len(InputString) 'get the input string length
For CharIndex = 1 To InputStringLength 'loop through each character
OneChar = VBA.Strings.Mid(InputString, CharIndex, 1) 'Read one character at a time
Select Case InStr(DelimitList, OneChar) 'Test if the character is a delimiter character
Case 0 'it is not a delimiter
TempWord = TempWord & OneChar 'Add the character to the current word
Case Is <> 0, Is = InputStringLength 'it is a delimiter or it is the last character
'if the temp word is not empty and not a quotation mark
If TempWord > "" And Not (TempWord = "'" Or TempWord = Chr(145) Or TempWord = Chr(146)) Then
TmpArr = TrimSingQuotes(TempWord) 'send that word to be cleaned from single quotaion mark
If (Not TmpArr(0) = "") Then 'if the returned word has length, count it
WordCount = WordCount + 1
ArrUbound = WordCount - 1 'set the new upper dimension for the storing array
ReDim Preserve ArrayOfWords(ArrUbound) 'expand storing array when we have a cleaned word with length
'Save new word in the last place inside the array, along with the word start and end ranges
ArrayOfWords(ArrUbound) = Array(TmpArr(0), _
CharIndex - Len(TempWord) + TmpArr(1) - 1, _
CharIndex - Len(TempWord) + TmpArr(2) - 1)
End If
TempWord = "" 'reset the Temp Word
End If
End Select
Next CharIndex
'===================================================================================================================
ExtractWordsFromDoc_2 = ArrayOfWords 'Return the storing array through function name
'do some cleaning
Erase ArrayOfWords
Erase TmpArr
End Function
Sub testTrimSingQuotes()
TrimSingQuotes (Empty)
End Sub
Function TrimSingQuotes(ByVal TempWord$)
'SSQP =starting single quote position
'ESQP = ending single quote position
'==================================================================
If TempWord = "" Then
TrimSingQuotes = Array("", 0, 0)
Exit Function
End If
'==================================================================
Dim SSQP&: SSQP = 1
Dim ESQP&: ESQP = Len(TempWord)
'==================================================================
'trim starting single quotes
Do While (Mid(TempWord, SSQP, 1) = "'" Or Mid(TempWord, SSQP, 1) = Chr(145) Or Mid(TempWord, SSQP, 1) = Chr(146)) And SSQP < ESQP
SSQP = SSQP + 1
Loop
'==================================================================
'trim ending single quotes
Do While (Mid(TempWord, ESQP, 1) = "'" Or Mid(TempWord, ESQP, 1) = Chr(145) Or Mid(TempWord, ESQP, 1) = Chr(146)) And (ESQP > SSQP)
ESQP = ESQP - 1
Loop
'==================================================================
'get the trimmed word
TempWord = Mid(TempWord, SSQP, ESQP - SSQP + 1)
'==================================================================
'test the trimmed word for output
If TempWord > "" And Not (TempWord = "'" Or TempWord = Chr(145) Or TempWord = Chr(146)) Then
TrimSingQuotes = Array(TempWord, SSQP, ESQP)
Else
TrimSingQuotes = Array("", 0, 0)
End If
End Function

Answer 1

To be honest, I didn't spend a lot of time (i.e. none) figuring out why your code isn't working as intended. I suspect it has something to do with calculating your position in the input string.
It is much simpler to leverage the build in Split function to do your heavy lifting, and probably much more performant than relying on the string functions like Instr and Mid. Note that this relies on 2 quirks of the Split function:
First, if you call Split on an empty string, it returns an array with a UBound of -1.
Second, VBA's version of Split doesn't remove empty entries - so, Split("foo", "foo") results in the array { vbNullString, vbNullString }. This is good, because you can tell by the result how many delimiters were in the string based on the size of the resulting array (number of delimiters in the input will always equal the number of array elements minus one. In VBA terms, delimiterCount = UBound(Split(inputString, delimiter)).
Your requirement makes this easy in that your delimiters are all 1 character.
Try something like this:
Private Function MultiSplit(inValue As String, delimiters() As Variant) As Variant()
Dim output() As Variant
Dim bound As Long
ReDim Preserve output(bound)
Dim tokens() As String
Dim index As Long
tokens = Split(inValue, delimiters(0))
If UBound(tokens) = -1 Then
MultiSplit = Array(vbNullString, 0, 0)
Exit Function
End If
'Process each delimiter.
For index = 1 To UBound(delimiters)
tokens = SubSplit(tokens, CStr(delimiters(index)))
Next index
Dim position As Long
For index = LBound(tokens) To UBound(tokens)
If tokens(index) = vbNullString Then
'This means a delimiter was removed, so increment the position to account for it.
position = position + 1
Else
'Resize the output array and write the result for the remaining token.
ReDim Preserve output(bound)
output(bound) = Array(tokens(index), position, position + Len(tokens(index)) - 1)
position = position + Len(tokens(index)) + 1
bound = bound + 1
End If
Next index
MultiSplit = output
End Function
Private Function SubSplit(inValue() As String, delimiter As String) As String()
Dim tokens() As String
Dim substring As Variant
Dim token As Variant
Dim output() As String
output = Split(vbNullString)
For Each substring In inValue
tokens = Split(substring, delimiter)
'Test for an empty token - these need to be preserved in the output.
If UBound(tokens) = -1 Then
ReDim Preserve output(UBound(output) + 1)
Else
For Each token In tokens
ReDim Preserve output(UBound(output) + 1)
output(UBound(output)) = token
Next token
End If
Next substring
SubSplit = output
End Function
Test code:
Private Function TestCode()
Dim delims() As Variant
Dim results() As Variant
Dim test As String
delims = Array(Chr(34), Chr(147), Chr(148), Chr(32), ",", ".", vbCr, vbTab, "/", "!", "|", ";", ")", "(", "?")
test = "foo|||bar,,baz?crux"
results = MultiSplit(test, delims)
Dim result As Variant
For Each result In results
Debug.Print result(0) & vbTab & result(1) & vbTab & result(2)
Next result
End Function
Note that I didn't examine the existing code even far enough to determine if your output positions were 1 or 0 based. The example above is 0 based. If you need 1 based, insert position = 1 after Dim position As Long.
Quote removal is left as an exercise for the reader.