Foro de elhacker.net

Private Sub Ejemplo()
Dim dels(3) As String
Dim result() As String
Const ss As String = "hola+como--andas(((esto====es+una--prueba"
    dels(0) = "+"
    dels(1) = "--"
    dels(2) = "((("
    dels(3) = "===="
 
    'sin preservar delimitadores
    result = MultiSplit7913(ss, dels, False)
    'result = ("hola";"como";"andas";"esto";"es";"una";"prueba")
 
    'preservando delimitadores
    result = MultiSplit7913(ss, dels, True)
    'result = ("hola";"+como";"--andas";"(((esto";"====es";"+una";"--prueba")
End Sub

Private Function MultiSplit7913(expression As String, Delimiter() As String, PreserveDel As Boolean) As String()
Dim DelCount    As Long
Dim lExp        As Long
Dim X           As Long
Dim Pos         As Long
Dim DelPos()    As Long
Dim AuxArr()    As String
Dim LastPos     As Long
Dim LastLen     As Long
Dim LastInstr   As Long
 
    expression = expression & Delimiter(0)
    lExp = Len(expression)
    DelCount = UBound(Delimiter)
    ReDim DelPos(lExp)
 
    For X = 0 To DelCount
        Pos = 1
        LastInstr = InStr(Pos, expression, Delimiter(X))
        Do While LastInstr <> 0
            DelPos(LastInstr) = X + 1
            Pos = LastInstr + Len(Delimiter(X)) + Pos
            LastInstr = InStr(Pos, expression, Delimiter(X))
        Loop
    Next
 
    ReDim AuxArr(0)
 
    LastPos = 1
 
    For X = 0 To lExp
        If DelPos(X) <> 0 Then
            ReDim Preserve AuxArr(UBound(AuxArr) + 1)
            If PreserveDel Then
                AuxArr(UBound(AuxArr) - 1) = Mid$(expression, LastPos, X - LastPos)
            Else
                AuxArr(UBound(AuxArr) - 1) = Mid$(expression, LastPos + LastLen, X - LastPos - LastLen)
                LastLen = Len(Delimiter(DelPos(X) - 1))
            End If
            LastPos = X
        End If
    Next
 
    ReDim Preserve AuxArr(UBound(AuxArr) - 1)
 
    MultiSplit7913 = AuxArr
 
End Function
 

• Podrias ahorrarte las 3 llamadas a InStr guardandolas en una sola variable :xD
• En lugar de guardar las posiciones con un flag, guarda en un array las posiciones de los delimitadores, asi despues evitas volver a recorrer la cadena (segundo for) y solo recorres el array y haces un mid, ya que tienes la posicion en el arreglo

Option Explicit
 
'// @ntdll.dll
Private Declare Sub RtlMoveMemory Lib "ntdll.dll" (ByVal Destiny As Long, ByVal Source As Long, ByVal Bytes As Long)
 
Private Type SPLIT_POSITION
    Mark        As Long
    LenBDel     As Long
End Type
 
Public Static Function MrFrogMultiSplit(ByRef strText$, ByRef strDelimiter$(), ByRef strOutputArray$()) As Boolean
Dim strTmpDel$, lngLenBDel&, lngLenBText&, lngUBDel&, lngLBDel&
Dim SP() As SPLIT_POSITION, tmpSP As SPLIT_POSITION
Dim lngCount&, lngStart&, B2c&, Q&, C&
 
    lngLenBText = VBA.Strings.LenB(strText)
    If (Not Not strDelimiter) And (lngLenBText > 0) Then
        lngLBDel = LBound(strDelimiter)
        lngUBDel = UBound(strDelimiter)
 
        ReDim SP(255) As SPLIT_POSITION
        lngCount = 0
 
        For Q = lngLBDel To lngUBDel
            strTmpDel = strDelimiter(Q)
            lngStart = VBA.Strings.InStrB(1, strText, strTmpDel)
 
            If (lngStart - 1)>0 Then
                lngLenBDel = VBA.LenB(strTmpDel)
 
                Do
                    tmpSP.Mark = lngStart
                    tmpSP.LenBDel = lngLenBDel
 
                    lngStart = VBA.Strings.InStrB(lngStart + lngLenBDel, strText, strTmpDel)
 
                    C = lngCount
                    If C Then
                        Do While tmpSP.Mark < SP(C - 1).Mark
                            C = C - 1
                            If C = 0 Then Exit Do
                        Loop
 
                        If C < lngCount Then
                            B2c = lngCount - C
                            RtlMoveMemory VarPtr(SP(C + 1)), VarPtr(SP(C)), B2c + B2c + B2c + B2c + B2c + B2c + B2c + B2c
                        End If
                    End If
                    SP(C) = tmpSP
 
                    lngCount = lngCount + 1
                    If lngCount And &HFF Then
                        ReDim Preserve SP(lngCount + &HFF) As SPLIT_POSITION
                    End If
                Loop While lngStart
            End If
        Next Q
 
        ReDim strOutputArray$(lngCount)
        lngCount = lngCount - 1
        lngStart = 1
 
        For Q = 0 To lngCount
            strOutputArray$(Q) = VBA.Strings.MidB$(strText, lngStart, SP(Q).Mark - lngStart)
            lngStart = SP(Q).Mark + SP(Q).LenBDel
        Next Q
 
        If (lngStart And Not 1) < lngLenBText Then
            strOutputArray$(Q) = VBA.Strings.MidB$(strText, lngStart, lngLenBText - lngStart + 2)
        End If
 
        MrFrogMultiSplit = True
    End If
End Function

Private Sub Form_Load()
Const strTest$ = "My+name--is(((MrFrog====and+I--love(((frogs... :P+hahaha===="
Dim strArr$(), strDels$()
Dim FixIdeBug&()
Dim vItem

    Debug.Assert Not FixIdeBug Or App.hInstance

    strDels = Split("+ -- ((( ====", " ")

    If MrFrogMultiSplit(strTest, strDels, strArr) Then
        Debug.Print "---> "; Time$; " <---"
    
        For Each vItem In strArr
            Debug.Print vItem
        Next vItem
    End If
End Sub