Thread: Split Text
View Single Post
 
Old 05-17-2015, 03:08 AM
fafalone fafalone is offline
Freshman
 
Join Date: May 2010
Posts: 37
Default

I used to use this function that includes support to split by ( ) et al, and support for multiple delimiters, option to retain parenthetical-type delimiters, and even an array that records the position of each item (it's part of an obscenely complex renaming program).

Code:
Public Function SplitEx(sz As String, _
                        dlms As Variant, _
                        Optional lLimit As Long = 0, _
                        Optional comp As VbCompareMethod = vbBinaryCompare, _
                        Optional bTruncateLimit As Boolean = False, _
                        Optional bRParen As Boolean = False, _
                        Optional bRBrack1 As Boolean = False, _
                        Optional bRBrack2 As Boolean = False, _
                        Optional bPosOut As Boolean = False, _
                        Optional vPos As Variant _
                                                                            ) As Variant
'Splits a string with an array of delimiters
'Also allows an option to split by pairs () [] {}
'with a further option to retain those characters
'when splitting

comp = cmDelim


Dim i As Long, j As Long, k As Long, c As Long, ST As Long, dl As Long
Dim szPart As String
Dim ar As Variant
Dim szDelims As String
Dim bParen As Boolean
Dim bBrack1 As Boolean
Dim bBrack2 As Boolean
ReDim vPos(0)

For i = LBound(dlms) To UBound(dlms)
    If (dlms(i) = "(") Or (dlms(i) = "()") Then
        bParen = True
        dlms(i) = ""
    End If
    If (dlms(i) = "[") Or (dlms(i) = "[]") Then
        bBrack1 = True
        dlms(i) = ""
    End If
    If (dlms(i) = "{") Or (dlms(i) = "{}") Then
        bBrack2 = True
        dlms(i) = ""
    End If
Next i

'szDelims = Join(dlms)

szPart = ""
ReDim ar(0)
c = 0

For i = 1 To Len(sz)
If (lLimit > 0) And (UBound(ar) = lLimit - 1) And (i < Len(sz)) And (bTruncateLimit = False) Then
    ar(c) = Mid(sz, i)
    Exit For
ElseIf (lLimit > 0) And (UBound(ar) = lLimit) And (i < Len(sz)) And (bTruncateLimit = True) Then
    Exit For
End If
    If bParen And (Mid(sz, i, 1) = "(") Then
        If szPart <> "" Then
            ar(c) = szPart
            If bPosOut Then
                vPos(c) = i - Len(szPart)
                ReDim Preserve vPos(c + 1)
            End If

            c = c + 1
            szPart = ""
            ReDim Preserve ar(c)
        End If
        j = InStr(i + 1, sz, ")")
        If j - (i + 1) > 0 Then
            For k = i + 1 To j - 1
                szPart = szPart & Mid(sz, k, 1)
            Next k
            If bRParen Then
                szPart = "(" & szPart & ")"
            End If
            ar(c) = szPart
            If bPosOut Then
                vPos(c) = i - Len(szPart)
                ReDim Preserve vPos(c + 1)
            End If
            c = c + 1
            szPart = ""
            ReDim Preserve ar(c)
            i = j
            GoTo nxt
        End If
    End If
    If bBrack1 And (Mid(sz, i, 1) = "[") Then
        If szPart <> "" Then
            ar(c) = szPart
            If bPosOut Then
                vPos(c) = i - Len(szPart)
                ReDim Preserve vPos(c + 1)
            End If

            c = c + 1
            szPart = ""
            ReDim Preserve ar(c)
        End If
        j = InStr(i + 1, sz, "]")
        If j - (i + 1) > 0 Then
            For k = i + 1 To j - 1
                szPart = szPart & Mid(sz, k, 1)
            Next k
            If bRBrack1 Then
                szPart = "[" & szPart & "]"
            End If
            ar(c) = szPart
            If bPosOut Then
                vPos(c) = i - Len(szPart)
                ReDim Preserve vPos(c + 1)
            End If

            c = c + 1
            szPart = ""
            ReDim Preserve ar(c)
            i = j
            GoTo nxt
        End If
    End If
    If bBrack2 And (Mid(sz, i, 1) = "{") Then
        If szPart <> "" Then
            ar(c) = szPart
            If bPosOut Then
                vPos(c) = i - Len(szPart)
                ReDim Preserve vPos(c + 1)
            End If

            c = c + 1
            szPart = ""
            ReDim Preserve ar(c)
        End If
        j = InStr(i + 1, sz, "}")
        If j - (i + 1) > 0 Then
            For k = i + 1 To j - 1
                szPart = szPart & Mid(sz, k, 1)
            Next k
            If bRBrack2 Then
                szPart = "{" & szPart & "}"
            End If
            ar(c) = szPart
            If bPosOut Then
                vPos(c) = i - Len(szPart)
                ReDim Preserve vPos(c + 1)
            End If

            c = c + 1
            szPart = ""
            ReDim Preserve ar(c)
            i = j
            GoTo nxt
        End If
    End If
'    If (InStr(1, szDelims, Mid(sz, i, 1), comp)) And ((szPart <> "") Or (UBound(ar) > 0)) Then
'        If szPart <> "" Then
'        ar(c) = szPart
'        c = c + 1
'        szPart = ""
'        ReDim Preserve ar(c)
'        End If
    dl = check_dlm(Mid(sz, i), dlms, comp)
    If dl > -1 Then
        If szPart <> "" Then
            ar(c) = szPart
            If bPosOut Then
                vPos(c) = i - Len(szPart)
                ReDim Preserve vPos(c + 1)
            End If

            c = c + 1
            szPart = ""
            ReDim Preserve ar(c)
            i = i + (dl - 1) 'advance position by length of matched delimiter (minus the one Next adds)
        End If
    Else
        szPart = szPart & Mid(sz, i, 1)
    End If
nxt:
Next i

If szPart <> "" Then
    ar(UBound(ar)) = szPart
    If bPosOut Then
        vPos(UBound(vPos)) = i - Len(szPart)
    End If

Else
    If CStr(ar(UBound(ar))) = "" Then
        ReDim Preserve ar(UBound(ar) - 1)
    End If
    If bPosOut Then
        If CStr(vPos(UBound(vPos))) = "" Then
            ReDim Preserve vPos(UBound(vPos) - 1)
        End If
    End If
End If


SplitEx = ar

End Function
Public Function check_dlm(szMid As String, d As Variant, cm As VbCompareMethod) As Long
'given a string starting at the point of interest, checks through an array
'of variable length delimiters and determines if the first characters
'match any of the delimiters.
'If it does, the length of the applicable delimiter is returned, otherwise
'the return is -1
Dim i As Long, j As Long
Dim tmpD As String

For i = LBound(d) To UBound(d)
    tmpD = d(i)
    If StrComp(Left(szMid, Len(tmpD)), tmpD, cm) = 0 Then
        check_dlm = Len(tmpD)
        Exit Function
    End If
Next i
check_dlm = -1
End Function
Not efficient or fast, but flexible.
Reply With Quote