Function MultiCritSplit(InString As String, Crit1 As String, Optional Crit2 As String, Optional Crit3 As String, Optional Crit4 As String, Optional Crit5 As String) As String()
Dim TmpString As String
Dim CritArray() As String
Dim OutArray() As String
Dim MidString As String
Dim ArrayCnt As Integer
Dim LenInString As Integer
Dim CharCnt As Integer
Dim ChkLoop As Integer
Dim ArrayID As Integer
Dim x As Integer
ArrayCnt = 0
' Validate
If Trim(Crit1) = "" Or Trim(InString) = "" Then
GoTo NoCrit
Else
ReDim CritArray(ArrayCnt)
CritArray(ArrayCnt) = Crit1
End If
If IsMissing(Crit2) = False Then
ArrayCnt = ArrayCnt + 1
ReDim Preserve CritArray(ArrayCnt)
CritArray(ArrayCnt) = Crit2
End If
If IsMissing(Crit3) = False Then
ArrayCnt = ArrayCnt + 1
ReDim Preserve CritArray(ArrayCnt)
CritArray(ArrayCnt) = Crit3
End If
If IsMissing(Crit4) = False Then
ArrayCnt = ArrayCnt + 1
ReDim Preserve CritArray(ArrayCnt)
CritArray(ArrayCnt) = Crit4
End If
If IsMissing(Crit5) = False Then
ArrayCnt = ArrayCnt + 1
ReDim Preserve CritArray(ArrayCnt)
CritArray(ArrayCnt) = Crit5
End If
' Split input string
ArrayID = 0
TmpString = InString
LenInString = Len(TmpString)
CharCnt = 1
x = 1
Do While LenInString > 0 And x < 10000
For ChkLoop = 0 To ArrayCnt
MidString = Mid(TmpString, CharCnt, 1)
If MidString = CritArray(ChkLoop) Then
ReDim Preserve OutArray(ArrayID)
OutArray(ArrayID) = Mid(TmpString, 1, CharCnt - 1)
TmpString = Right(TmpString, LenInString - CharCnt)
LenInString = Len(TmpString)
ArrayID = ArrayID + 1
CharCnt = 1
Exit For
End If
Next ChkLoop
CharCnt = CharCnt + 1
x = x + 1
Loop
MultiCritSplit = OutArray
Exit Function
NoCrit:
End Function
Sub TestSplit()
Dim RplyArray() As String
Dim LbRArray As Integer
Dim UbRArray As Integer
Dim Rloop As Integer
RplyArray = MultiCritSplit(Range("A1").Value, ",", "?", ".", ";", "!")
LbRArray = LBound(RplyArray)
UbRArray = UBound(RplyArray)
For Rloop = LbRArray To UbRArray
Range("A" & 3 + Rloop).Value = RplyArray(Rloop)
Next Rloop
End Sub
