Obtain positions of text character string from text block

[mresann]

This is a simple but handy function that allows you to obtain the positions of characters within a text block. Say you have a line of text, or block of text, as follows:

An apple a day keeps the doctor away.

Now you would like to find the all the character positions of the letter “a” within the block of text. In this case, you would like to see the values returned as follows:

1, 4, 10, 13, 33, 35

While it’s a simple matter of creating a looping function that increments through all the individual characters, it becomes more complicated when you must look for multiple-length characters, such as “aw.” In addition, in longer blocks of text, maybe one of several thousand characters, you may wish to designate a starting point and/or a stopping point within the text block, while returning the character positions relative to the text block as a whole. In addition, you may wish to use the exact case of a character, (specifically, “a” does not equal “A”). Finally, you may wish to return the character positions as a string variable with a delimiter rather than as an array variable.

The attachment includes a word document, a single web page document (identical to the word document), and the database containing the module along with a form that demonstrates the function. You can also copy the function provided in the code below if you don't have a later version of Access to open the 2016 file.

Option Explicit

'-----------------------------------------------------------------------------------------
' Procedure : fncCharPosition
' Created   : 1/10/2007 17:57
' Modified  : 11/21/2018
' Reference : fncCharPosition*
' Author    : Michael Reese
' Inputs    : strTextBlock: Text block in which the character string resides to count
'           : strCharacter: String of text of which to count
'           : strFlagStart (optional): String of text located in text block indicating
'           :   the starting point to locate character string
'           : lngCompare (optional): Indicates whether text to check is case sensitive
'           : lngBaseStart (optional): Indicates the starting base for the return array
'           : strFlagStop (optional): String of text located in text block indicating
'           :   the end point to locate character string
'           : blnRecursive (optional): Indicates whether character strings can be counted
'           :   if they are part of character strings already counted
'           : blnReturnString (optional): Indicates whether a delineated string is re-
'           :   turned rather than an array variant
' Output    : A variant containing the array of all character positions within the text
'           :   block for character strings, or a variant containing the delimited string
'           :   containing all character positions within the text block for character strings
' Purpose   : Returns positions of character strings within a text block, or within a
'           :   substring of the text block, in either a variant array variable or a
'           :   string with delimiters.
'-----------------------------------------------------------------------------------------

Public Function fncCharPosition( _
      ByVal strTextBlock As String, _
      ByVal strCharacter As String, _
      Optional ByVal strFlagStart As String, _
      Optional ByVal lngCompare As Long = vbTextCompare, _
      Optional ByVal lngBaseStart As Long, _
      Optional ByVal strFlagStop As String, _
      Optional ByVal blnRecursive As Boolean, _
      Optional ByVal blnReturnString As Boolean _
      ) As Variant

'|<------ 90-character width -------------------------------- 90-character width ------->|

PROC_DECLARATIONS:
   Dim avarCharPosition()  As Variant
   Dim lngCharPosition     As Long
   Dim lngCharLength       As Long
   Dim lngIndex            As Long
   Dim lngFileTextLength   As Long
   Dim blnCharPresent      As Boolean
   Dim blnFlagStart        As Boolean
   Dim blnFlagStop         As Boolean
   Dim lngStart            As Long
   Dim strReturnString     As String
   
PROC_START:
   On Error GoTo PROC_ERROR
   ReDim avarCharPosition(lngBaseStart)
   avarCharPosition(lngBaseStart) = 0
   lngIndex = lngBaseStart
   lngStart = 1
   blnCharPresent = True
   lngCharLength = Len(strCharacter)
   lngFileTextLength = Len(strTextBlock)
   strReturnString = Space(0)
   blnFlagStart = Len(strFlagStart) > 0
   blnFlagStop = Len(strFlagStop) > 0
   
PROC_MAIN:
   'Ensure required arguments are passed
   If Nz(strTextBlock, Space(0)) = Space(0) Or _
         Nz(strCharacter, Space(0)) = Space(0) Then
      If blnReturnString Then
         fncCharPosition = Space(0)
      Else
         fncCharPosition = avarCharPosition()
      End If
      GoTo PROC_EXIT
   End If
      
   'Determine starting point of text block to look for character positions
   If blnFlagStart Then
      lngStart = InStr(1, strTextBlock, strFlagStart, lngCompare) + Len(strFlagStart)
   End If
   
   'Determine stopping point of text block to look for character positions
   If blnFlagStop Then
      If InStr(lngStart, strTextBlock, strFlagStop, lngCompare) > 0 Then
         lngFileTextLength = InStr(lngStart, strTextBlock, strFlagStop, lngCompare)
      End If
   End If
   
   'Determine if character positions can be found within resulting text block search parameters
   If InStr(1, Mid(strTextBlock, lngStart, lngFileTextLength - (lngStart - 1)), _
         strCharacter, lngCompare) = 0 Then
      GoTo PROC_EXIT
   End If
   
   'Cycle through text block to determine character positions
   For lngCharPosition = lngStart To lngFileTextLength
      If StrComp(strCharacter, Mid(strTextBlock, lngCharPosition, lngCharLength), lngCompare) = 0 Then
         lngIndex = lngIndex + 1
         ReDim Preserve avarCharPosition(lngIndex)
         avarCharPosition(lngIndex) = lngCharPosition
         If blnFlagStart Then
            If InStr(lngCharPosition, strTextBlock, strCharacter, lngCompare) > 0 Then
               lngCharPosition = InStr(lngCharPosition, strTextBlock, strCharacter, lngCompare) + 1
            End If
         Else
            If Not blnRecursive Then
               lngCharPosition = lngCharPosition + (lngCharLength - 1)
            End If
         End If
      End If
   Next
   
   'Ensures proper array index assignments
   If UBound(avarCharPosition) > lngBaseStart Then
      For lngIndex = lngBaseStart + 1 To UBound(avarCharPosition)
         avarCharPosition(lngIndex - 1) = avarCharPosition(lngIndex)
      Next
   End If
   
   ReDim Preserve avarCharPosition(UBound(avarCharPosition) - 1)
   
PROC_EXIT:
   If blnReturnString Then
      'assigns function return to delimited string
      fncCharPosition = Right(Join(avarCharPosition, ";"), _
            Len(Join(avarCharPosition, ";")) - lngBaseStart)
   Else
      'assigns function return to array variant
      fncCharPosition = avarCharPosition
   End If
   
   Exit Function

PROC_ERROR:
   MsgBox "Error " & Err.Number & " (" & _
           Err.Description & ")" & vbCrLf & vbCrLf & _
           "Procedure: fncCharPosition" & vbCrLf & _
           "Module: basCharacterPosition"
   GoTo PROC_EXIT
      
End Function