Title:VBA String Functions
Author:Mark Kiehl
Category:VBA
'I found these string functions to be robust, bug free, and they handle every need not built into VBA.

Option Explicit

'Copy this module to the Modules in your workbook. Then you can reference the formulas
'directly. Otherwise you must use it as an Add-In.

'String Functions Library
'This library contains various VBA functions for often-used string handling needs
'Usage note: All string comparisons use binary comparison, i.e. "A" <> "a"
'Copyright 2000 Roman Koch (roman@romankoch.ch)
'http://www.romankoch.ch/capslock/strfun.htm

Public Const Blank As String = " "

Function SF_count(ByVal Haystack As String, ByVal Needle As String) As Long
'count the number of occurences of needle in haystack
'SF_count(" This is my string ","i") returns 3
Dim i As Long, j As Long
If SF_isNothing(Needle) Then
SF_count = 0
Else
i = InStr(1, Haystack, Needle, vbBinaryCompare)
If i = 0 Then
SF_count = 0
Else
i = 0
For j = 1 To Len(Haystack)
If Mid(Haystack, j, Len(Needle)) = Needle Then i = i + 1
Next j
SF_count = i
End If
End If
End Function

Function SF_countWords(ByVal Haystack As String) As Long
'count number of words in a string
'if the string is empty, 0 is returned
'SF_countWords(" This is my string ") returns 4
Dim strChar As String
Dim lngCount As Long, i As Long
Haystack = SF_unSpace(Haystack)
If SF_isNothing(Haystack) Then
SF_countWords = 0
Else
lngCount = 1
For i = 1 To Len(Haystack)
strChar = Mid(Haystack, i, 1)
If strChar = Blank Then
lngCount = lngCount + 1
End If
Next i
SF_countWords = lngCount
End If
End Function

Function SF_getWord(ByVal Haystack As String, ByVal WordNumber As Long) As String
'return nth word of a string
'if the string is empty, a zero-length string is returned
'if there is only one word, the initial string is returned
'if wordnumber is 0 or negative, a zero-length string is returned
'if wordnumber is larger than the number of words in the string, a zero-length string is returned
'SF_getWord(" This is my string ",2) returns "is"
Dim i, lngWords As Long
Haystack = SF_unSpace(Haystack)
If SF_isNothing(Haystack) Then
SF_getWord = Haystack
Else
If WordNumber > 0 Then
lngWords = SF_countWords(Haystack)
If WordNumber > lngWords Then
Haystack = ""
Else
If lngWords > 1 Then
'cut words at the left
For i = 1 To WordNumber - 1
Haystack = Mid(Haystack, InStr(Haystack, Blank) + 1)
Next i
'cut words at the right, if any
i = InStr(Haystack, Blank)
If i > 0 Then Haystack = Left(Haystack, i - 1)
End If
End If
Else
Haystack = ""
End If
SF_getWord = Haystack
End If
End Function

Function SF_InstrRev(ByVal Haystack As String, ByVal Needle As String) As Long
'find the last occurence of needle in haystack (the VB instr function finds the first occurence)
'SF_InstrRev(" This is my string ","i") = 20
Dim i As Long, j As Long
i = InStr(1, Haystack, Needle, vbBinaryCompare)
If SF_isNothing(Needle) Then
SF_InstrRev = 0
Else
If i = 0 Then
SF_InstrRev = 0
Else
If StrComp(Needle, Haystack, vbBinaryCompare) = 0 Then
SF_InstrRev = 1
Else
For j = Len(Haystack) To 1 Step -1
i = InStr(j, Haystack, Needle, vbBinaryCompare)
If i > 0 Then
SF_InstrRev = i
Exit Function
End If
Next j
End If
End If
End If
End Function

Function SF_isNothing(ByVal Haystack As String) As Boolean
'check if there is anything in a string (to avoid testing for
'isnull, isempty, and zero-length strings)
'SF_isNothing(" This is my string ") returns False
If Haystack & "" = "" Then
SF_isNothing = True
Else
SF_isNothing = False
End If
End Function

Function SF_remove(ByVal Haystack As String, ByVal Needle As String) As String
'remove first occurence of needle in haystack
'if needle is empty or not found, haystack is returned
'if needle is equal to haystack, a zero-length string is returned
'SF_remove(" This is my string "," This is m") returns "y string "
Dim i As Long
If SF_isNothing(Needle) Then
SF_remove = Haystack
Else
i = InStr(1, Haystack, Needle, vbBinaryCompare)
If i = 0 Then
SF_remove = Haystack
Else
SF_remove = SF_splitLeft(Haystack, Needle) & SF_splitRight(Haystack, Needle)
End If
End If
End Function

Function SF_removeRev(ByVal Haystack As String, ByVal Needle As String) As String
'remove last occurence of needle in haystack
'if needle is empty or not found, haystack is returned
'if needle is equal to haystack, a zero-length string is returned
'SF_removeRev(" This is my string ","i") returns " This is my strng "
Dim i As Long
If SF_isNothing(Needle) Then
SF_removeRev = Haystack
Else
i = SF_InstrRev(Haystack, Needle)
If i = 0 Then
SF_removeRev = Haystack
Else
SF_removeRev = Left(Haystack, i - 1) & Mid(Haystack, i + Len(Needle))
End If
End If

End Function

Function SF_removeAllOnce(ByVal Haystack As String, ByVal Needle As String) As String
'remove all occurrences of needle in haystack exactly once
'if needle is empty or not found, haystack is returned
'if needle is equal to haystack, a zero-length string is returned
'SF_removeAllOnce("1122a1122","12") returns "12a12"
Dim i As Long
If SF_isNothing(Needle) Then
SF_removeAllOnce = Haystack
Else
i = InStr(1, Haystack, Needle, vbBinaryCompare)
Do While i > 0
Haystack = Left(Haystack, i - 1) & Mid(Haystack, i + Len(Needle))
i = InStr(i, Haystack, Needle, vbBinaryCompare)
Loop
SF_removeAllOnce = Haystack
End If
End Function

Function SF_removeAll(ByVal Haystack As String, ByVal Needle As String) As String
'remove all occurrences of needle in haystack, even those created during removal
'if needle is empty or not found, haystack is returned
'if needle is equal to haystack, a zero-length string is returned
'SF_removeAll("1122a1122","12") returns "a"
Do While InStr(1, Haystack, Needle) > 0
Haystack = SF_removeAllOnce(Haystack, Needle)
Loop
SF_removeAll = Haystack
End Function

Function SF_replace(ByVal Haystack As String, ByVal Needle As String, ByVal NewNeedle As String) As String
'replace first occurence of needle in haystack with newneedle
'if needle is empty or not found, haystack is returned
'if needle is equal to haystack, newneedle is returned
'if needle is equal to newneedle, haystack is returned
'SF_replace(" This is my string ","my","your") returns " This is your string "
Dim i As Long
If SF_isNothing(Needle) Then
SF_replace = Haystack
Else
If StrComp(Needle, NewNeedle, vbBinaryCompare) = 0 Then
SF_replace = Haystack
Else
i = InStr(1, Haystack, Needle, vbBinaryCompare)
If i = 0 Then
SF_replace = Haystack
Else
SF_replace = SF_splitLeft(Haystack, Needle) & NewNeedle & SF_splitRight(Haystack, Needle)
End If
End If
End If
End Function

Function sf_replaceRev(ByVal Haystack As String, ByVal Needle As String, ByVal NewNeedle As String) As String
'replace last occurence of needle in haystack with newneedle
'if needle is empty or not found, haystack is returned
'if needle is equal to haystack, newneedle is returned
'if needle is equal to newneedle, haystack is returned
'SF_replaceRev(" This is my string ","i","o") returns " This is my strong "
Dim i As Long
If SF_isNothing(Needle) Then
sf_replaceRev = Haystack
Else
If StrComp(Needle, NewNeedle, vbBinaryCompare) = 0 Then
sf_replaceRev = Haystack
Else
i = SF_InstrRev(Haystack, Needle)
If i = 0 Then
sf_replaceRev = Haystack
Else
sf_replaceRev = Left(Haystack, i - 1) & NewNeedle & Mid(Haystack, i + Len(Needle))
End If
End If
End If
End Function

Function SF_replaceAllOnce(ByVal Haystack As String, ByVal Needle As String, ByVal NewNeedle As String) As String
'replace all occurrences of needle in haystack with newneedle exactly once
'if needle is empty or not found, haystack is returned
'if needle is equal to newneedle, haystack is returned
'if needle is equal to haystack, newneedle is returned
'SF_replaceAllOnce(" This is my string ","i","ee") returns " Thees ees my streeng "
Dim i As Long
If SF_isNothing(Needle) Then
SF_replaceAllOnce = Haystack
Else
If StrComp(Needle, NewNeedle, vbBinaryCompare) = 0 Then
SF_replaceAllOnce = Haystack
Else
i = InStr(1, Haystack, Needle, vbBinaryCompare)
Do While i > 0
Haystack = Left(Haystack, i - 1) & NewNeedle & Mid(Haystack, i + Len(Needle))
i = i + Len(NewNeedle)
i = InStr(i, Haystack, Needle, vbBinaryCompare)
Loop
SF_replaceAllOnce = Haystack
End If
End If
End Function

Function SF_replaceAll(ByVal Haystack As String, ByVal Needle As String, ByVal NewNeedle As String) As String
'replace all occurrences of needle in haystack with newneedle, even those created during replacing
'if needle is empty or not found, haystack is returned
'if needle is equal to newneedle, haystack is returned
'if needle is equal to haystack, newneedle is returned
'if needle is a subset of newneedle, the function would loop;
'to avoid this, SF_replaceAllOnce is executed instead
'SF_replaceAll(" This is my string ","i","ee") returns " Thees ees my streeng "
If InStr(1, NewNeedle, Needle, vbBinaryCompare) > 0 Then
Haystack = SF_replaceAllOnce(Haystack, Needle, NewNeedle)
Else
Do While InStr(1, Haystack, Needle, vbBinaryCompare) > 0
Haystack = SF_replaceAllOnce(Haystack, Needle, NewNeedle)
Loop
End If
SF_replaceAll = Haystack
End Function

Function SF_splitLeft(ByVal Haystack As String, ByVal Needle As String) As String
'return left part of haystack delimited by the first occurrence of needle
'if needle is empty or not found, haystack is returned
'if haystack starts with needle (or is equal to needle), a zero-length string is returned
'SF_splitLeft(" This is my string ","s is") returns " Thi"
Dim i As Long
If SF_isNothing(Needle) Then
SF_splitLeft = Haystack
Else
i = InStr(1, Haystack, Needle, vbBinaryCompare)
If i = 0 Then
SF_splitLeft = Haystack
Else
SF_splitLeft = Left(Haystack, i - 1)
End If
End If
End Function

Function SF_splitRight(ByVal Haystack As String, ByVal Needle As String) As String
'return right part of haystack delimited by the first occurrence of needle
'if needle is empty or not found, haystack is returned
'if haystack ends with needle (or is equal to needle), a zero-length string is returned
'SF_splitRight(" This is my string "," my s") returns "tring "
Dim i As Long
If SF_isNothing(Needle) Then
SF_splitRight = Haystack
Else
i = InStr(1, Haystack, Needle, vbBinaryCompare)
If i = 0 Then
SF_splitRight = Haystack
Else
SF_splitRight = Mid(Haystack, i + Len(Needle))
End If
End If
End Function

Function SF_unSpace(ByVal Haystack As String) As String
'remove duplicate blanks in a string
'SF_unspace(" This is my string ") returns "This is my string"
If SF_isNothing(Haystack) Then
SF_unSpace = Haystack
Else
Haystack = Trim(Haystack)
Do While InStr(Haystack, Blank & Blank) > 0
Haystack = SF_replaceAllOnce(Haystack, Blank & Blank, Blank)
Loop
SF_unSpace = Haystack
End If
End Function

Function SF_RemoveNonPrt(ByVal Haystack As String) As String
Dim i As Integer
'remove non printable characters, ASCII 0-31 and 127-255 (decimal).
'Copyright (C) Mark Kiehl, 2007.
If SF_isNothing(Haystack) Then
SF_RemoveNonPrt = Haystack
Else
For i = 0 To 31
Haystack = SF_removeAllOnce(Haystack, String$(1, Chr(i)))
Next i
For i = 127 To 255
Haystack = SF_removeAllOnce(Haystack, String$(1, Chr(i)))
Next i
SF_RemoveNonPrt = Haystack
End If
End Function

Function SF_AddRandomNonPrt(ByVal Haystack As String) As String
Dim i As Integer, iLeft As Integer, iRight As Integer, iRnd As Integer
'Add non printable characters, ASCII 0-31 and 127-255 (decimal) at random.
'Copyright (C) Mark Kiehl, 2007.
If SF_isNothing(Haystack) Then
SF_AddRandomNonPrt = Haystack
Else
iLeft = Len(Haystack) / 2
iRight = Len(Haystack) - iLeft
'Int((upperbound - lowerbound + 1) * Rnd + lowerbound)
iRnd = Int((31 - 1 + 1) * Rnd + 1) ' Generate random value between 1 and 31.
Haystack = Left(Haystack, iLeft) & String$(1, Chr(iRnd)) & Right(Haystack, iRight)
iRnd = Int((255 - 127 + 1) * Rnd + 127) ' Generate random value between 127 and 255.
Haystack = Haystack & String$(1, Chr(iRnd))
SF_AddRandomNonPrt = Haystack
End If
End Function